perm filename TOTAL[S,AIL]51 blob
sn#342546 filedate 1978-03-26 generic text, type T, neo UTF8
00100 COMMENT ⊗ VALID 00052 PAGES
00200 C REC PAGE DESCRIPTION
00300 C00001 00001
00400 C00005 00002 HISTORY
00500 C00013 00003 DATA for Total (Low-level Code Production) Routines
00600 C00016 00004 Description of Total Routines
00700 C00026 00005 CONV, PRE, POST -- Type-Conversion routines
00800 C00032 00006
00900 C00036 00007
01000 C00043 00008
01100 C00045 00009 PUT
01200 C00049 00010 ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
01300 C00059 00011 GET
01400 C00066 00012
01500 C00069 00013
01600 C00073 00014
01700 C00079 00015 STACK -- Issue Instrs. to Stack Anything on Approp. Stack
01800 C00084 00016 MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
01900 C00088 00017 INCOR -- Issue Code to Clear this Entity from ACs
02000 C00089 00018 REMOPs, CLEARs -- Remove Temps, ACs, from Use
02100 C00101 00019 DSCR CLEAR,CLEARL,CLEARA
02200 C00104 00020 STROP -- Bit-Driven String Operation Code Generator
02300 C00111 00021 GETTEM, etc. -- Temp Semblk Allocators
02400 C00115 00022 GETAC, GETAN0 -- AC Allocators
02500 C00121 00023 AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ
02600 C00126 00024 STORA -- main AC-storing subr. -- called by above
02700 C00133 00025 EMITER -- Descriptions of Routine and Control Bits
02800 C00136 00026 EMITER Routine
02900 C00140 00027
03000 C00146 00028 SUBI TEMP,1 FIX IT
03100 C00152 00029
03200 C00155 00030 Qstack Routines -- BPUSH, etc.
03300 C00159 00031
03400 C00162 00032
03500 C00165 00033 PWR2
03600 C00166 00034 GBOUT Description, Loader Block Format Description
03700 C00169 00035 Control Variables for Loader Block Output
03800 C00172 00036 Loader Output Blocks-- Entry, Program Name, Initial Stuff
03900 C00176 00037 Code, Boolean Code, Fixups, Links
04000 C00180 00038 Space Allocation Block
04100 C00184 00039 Request Blocks -- RELfile, Libraries
04200 C00186 00040 Ending Code, Symbols -- END Block
04300 C00190 00041 RELINI -- Loader Block Initialization
04400 C00191 00042 GBOUT Routine
04500 C00194 00043 CODOUT Routine -- Output Code or Data
04600 C00198 00044
04700 C00199 00045 FBOUT, etc. -- Output Fixups
04800 C00202 00046 SCOUT, etc. -- Output Symbols
04900 C00206 00047 LNKOUT -- Output Linkage Block
05000 C00208 00048 PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst
05100 C00218 00049
05200 C00221 00050 >NOTENX
05300 C00223 00051 RAD50, RAD52 -- Radix-50 Functions for Scout Routines
05400 C00227 00052
05500 C00228 ENDMK
05600 C⊗;
00100 COMMENT ⊗HISTORY
00200 AUTHOR,REASON
00300 021 102100000044 ⊗;
00400
00500
00600 COMMENT ⊗
00700 VERSION 17-1(36) 3-7-75 BY RHT BUG #UE# STRING ARRAY ISNT A STRING
00800 VERSION 17-1(35) 2-16-75 BY JFR BAIL P.35 DEFINE RESIDENCE OF RUNTIME PROCEDURE DESCRIPTORS
00900 VERSION 17-1(34) 12-7-74 BY JFR DEFINE RESIDENCE OF BAIL LOADMODULE
01000 VERSION 17-1(33) 11-3-74 BY RHT BUG TR MAKE GBOUT HONEST ABOUT WORD COUNT
01100 VERSION 17-1(32) 10-10-74 BY RHT FEAT %BR% (REMOVE HACKS)
01200 VERSION 17-1(31) 7-24-74 BY RHT BUG #SV# GET SPAC OF RECORD WAS LOSING
01300 VERSION 17-1(30) 7-22-74 BY RHT BUG #SU# CONV(ARITH) FOR PNTVAR
01400 VERSION 17-1(29) 7-7-74 BY RHT MANY EDITS FOR RECGC
01500 VERSION 17-1(28) 7-7-74
01600 VERSION 17-1(27) 7-7-74
01700 VERSION 17-1(26) 7-7-74
01800 VERSION 17-1(25) 5-30-74 BY RLS TENEX BUG #SK# DONT MESS UP DEVICE NAME FOR LOAD!MODULE
01900 VERSION 17-1(24) 5-20-74 BY RHT BUG #SA# SHOULD NOT BUMP REF CNT ON GET ADDR
02000 VERSION 17-1(23) 5-14-74 BY RHT BUG #RY# RECUUO (AC) S/B RECUUO 0,AC
02100 VERSION 17-1(22) 4-18-74
02200 VERSION 17-1(21) 4-12-74 BY RHT %BI% MAKE EMITTER KNOW ABOUT RECORD CLASSES
02300 VERSION 17-1(20) 4-12-74 BY RHT %BI% ADD SOME LOW LEVEL RECORD STUFF
02400 VERSION 17-1(19) 4-12-74
02500 VERSION 17-1(18) 4-12-74
02600 VERSION 17-1(17) 4-12-74
02700 VERSION 17-1(16) 4-12-74
02800 VERSION 17-1(15) 4-12-74
02900 VERSION 17-1(14) 4-6-74 BY RLS TENEX
03000 VERSION 17-1(13) 3-17-74 BY RLS TENEX ADDITIONS
03100 VERSION 17-1(13) 2-13-74 BY JRL BUG #RE# STRING ITEMVAR ARRAY NOT STRING ARRAY
03200 VERSION 17-1(12) 1-11-74 BY JRL CMU CHANGE COMVER (UNDER NOHACK)
03300 VERSION 17-1(11) 12-8-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
03400 VERSION 17-1(10) 11-24-73 BY RHT %AL% TAKE HRLOI 12, OUT OF S. SEQUENCE
03500 VERSION 17-1(9) 11-24-73 BY RFS RADIX50 TYPE BITS NOT INSTALLED IN RAD5$, RAD5%
03600 VERSION 17-1(8) 11-13-73 BY JRL FORCE PUT TO ALWAYS DO AN ACCESS
03700 VERSION 17-1(7) 11-13-73 BY JRL BUG #PA# GET ADDR OF MPPARM WAS DESTROYING AC C
03800 VERSION 17-1(6) 11-13-73 BY JRL BUG #OZ# FIX GET FOR INSISTED ITEMVARS
03900 VERSION 17-1(5) 11-4-73 BY JRL BUG #OX# LET PUT KNOW ABOUT ? ITEMVARS
04000 VERSION 17-1(4) 10-26-73 BY JRL BUG #OR# A STRING ITEM IS NOT A STRING
04100 VERSION 17-1(3) 10-23-73 BY JRL FEATURE %AG& ITEM OVERLAP STUFF
04200 VERSION 17-1(2) 8-16-73 BY JRL REMOVE REFERENCES TO LEAPSW
04300 VERSION 17-1(1) 8-2-73 BY JRL BUG #NK# TEMPS SHOULD NOT HAVE DISPLAY LEVELS
04400 VERSION 17-1(0) 7-26-73 BY RHT **** VERSION IS 17 ****
04500 VERSION 16-2(31) 7-13-73 BY RHT MODIFY SOUT FOR FNYNAM
04600 VERSION 16-2(30) 7-13-73 BY RHT BUG #MN# A DREADFUL KLUGE TO FIX ACCESS BUG
04700 VERSION 16-2(29) 7-13-73
04800 VERSION 16-2(28) 6-28-73 BY JRL BUG #KA#B IMMEDIATE INSTRUCTIONS NOT USED FOR OR,AND
04900 VERSION 16-2(27) 3-19-73 BY RHT CHANGE SOUT SO STACK SYMBOLS WORK RIGHT
05000 VERSION 16-2(26) 3-13-73 BY JRL REMOVE REFERENCES TO WOM,SLS,GAG,NODIS
05100 VERSION 16-2(25) 2-26-73 BY JRL DO A SKIPE NOEMIT IN XCALLQ
05200 VERSION 16-2(24) 2-6-73 BY JRL MAKE GET HONEST FOR QPARS
05300 VERSION 16-2(23) 1-31-73 BY HJS DISABLE CODOUT, EMITER, AND FBOUT FOR EXPR!TYPE
05400 VERSION 16-2(22) 12-13-72 BY JRL BUG #KS# ADD LOADVR SWITCH
05500 VERSION 16-2(21) 12-13-72
05600 VERSION 16-2(20) 11-30-72 BY JRL MAKE GET HONEST FOR ? ITEMVARS
05700 VERSION 16-2(19) 11-30-72 BY JRL BUG #KQ# IGNORE FIXARRS IN STORA
05800 VERSION 16-2(18) 11-21-72 BY RHT BUG #KH# DEL FORMFX STUFF FROM SIMPROC FORMALS
05900 VERSION 16-2(17) 10-17-72 BY JRL BUG #JR# STRING ITEMVARS NOT STRING
06000 VERSION 16-2(16) 8-29-72 BY KVL ADD CKECK FOR UNTYPED IN PRE
06100 VERSION 16-2(15) 7-17-72 BY RHT BUG #IO# EVAR MESSED UP BY INDEXED STRING TEMP
06200 VERSION 16-2(14) 7-8-72 BY RHT BUG ##I#L# GET ACCESS TO A VARIABLE IN PRE BEFORE INSISTING
06300 VERSION 16-2(13) 6-30-72 BY DCS BUG #IA# PROTECT PTRAC AC OVER FIX, FLOAT, STRING to INTEGER
06400 VERSION 16-2(12) 6-25-72 BY DCS BUG #HX# PARAMETERIZE LIBRARY NAMES (OTHER THINGS)
06500 VERSION 16-2(11) 6-20-72 BY DCS BUG #HU# BETTER TTY PRINTOUT
06600 VERSION 16-2(10) 6-14-72 BY JRL BUG #HS# AN ITEMVAR IS NOT ITS DATUM(MARK).
06700 VERSION 16-2(9) 5-13-72 BY DCS BUG #HF# MAKE GETAC MUCH MORE HONEST
06800 VERSION 15-2(8) 3-25-72 BY DCS BAD ARRAY ADDRESS PROBLEM
06900 VERSION 15-2(7) 3-10-72 BY DCS REPLACE RING, ULINK MACROS WITH ROUTINES
07000 VERSION 15-2(6) 2-9-72 BY DCS BUG #GQ# MAKE ! = UNDERLINE IN RADIX50
07100 VERSION 15-2(5) 2-5-72 BY DCS BUG #GJ# ADD LSTON LISTING CONTROL STUFF
07200 VERSION 15-2(4) 2-1-72 BY DCS ISSUE %ALLOC SPACE REQUESTS IN NEW WAY (SEE GOGOL FOR FORMAT)
07300 VERSION 15-2(3) 1-10-72 BY DCS BUG #FP# FIX A NEGAT BUG
07400 VERSION 15-2(2) 1-7-72 BY DCS BUG #FY# Fix Strvar←INAC-Intvar bookkeeping problem
07500 VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
07600
07700 ⊗;
07800
00100 COMMENT ⊗DATA for Total (Low-level Code Production) Routines⊗
00200 LSTON (TOTAL)
00300
00400 SUBTTL WIZARD'S DEN -- Generator Called Routines.
00500 BEGIN TOTAL
00600
00700 ZERODATA (TOTAL ROUTINE VARIABLES)
00800
00900 ;ACKPNT -- next AC # GETAC should try -- used to distribute
01000 ; AC usages among the ACs -- used by GETAC only
01100 ?ACKPNT: 0
01200
01300 COMMENT ⊗
01400 FORMFX -- QSTACK descriptor for formal fixups. Until a recursive
01500 Procedure has been completely compiled, it is not known how
01600 many local strings and non-strings will be saved in the runtime
01700 stacks between the stack tops and the formal parameters. Therefore
01800 as instructions accessing parameters are issued, the address
01900 field displacements (assuming 0 locals) are saved, along with
02000 the addresses where they are issued, in the FORMFX stack.
02100 The left half of each entry is the address of the instruction--
02200 the right half is the desired relative displacement (high-order
02300 bit specifies String stack or System stack). After the procedure
02400 is compiled, these entries are QPOPed off and used, along with
02500 the ALOCALS, SLOCALS counts (see PROCED variables) to issue
02600 fixups for these instructions. This Qstack is not used
02700 for non-recursive Procedures
02800 ⊗
02900 ↑↑FORMFX: 0
03000
03100 ?POSSIB: 0 ;TEMP USED BY GETAC WHEN GETTING 2
03200
03300 ;TEMPNO -- each temp Semblk allocated is assigned a unique
03400 ; number, by incrementing TEMPNO -- a temp Semblk may
03500 ; be used several times in the same procedure. See GETTEM
03600 ; for description of the mysteries of temps.
03700 ?TEMPNO: 0
03800
03900 ENDDATA
04000
00100 COMMENT ⊗Description of Total Routines⊗
00200
00300 DSCR CONV,ACCESS,GET,PUT,STACK,MARK
00400 DES This is the generalized move code. (i.e. called by macro GENMOV).
00500 It consists of several routines which are called in a uniform
00600 fashion. This fashion stipulates that "directive" bits be passed
00700 in the right half of FF which specify modifiers on the operation
00800 of the routine called. Each routine is preceded by a standard
00900 preamble (PRE) and followed by a standard epilog (POST).
01000
01100 Some of the directive bits control PRE and POST. They are:
01200
01300 PAR
01400 PRE:
01500 1. If the GETD bit is on, we do a GETAD first (i.e. use PNT
01600 as the pointer to a symbol table entry, and fill TBITS
01700 and SBITS. This is useful since many of the GENMOV routines
01800 require that TBITS and SBITS be set up.
01900 2. If the PROTECT bit is set, then register D is assumed to have
02000 an accumulator number in it. That accumulator table entry
02100 is "protected". I.e. calls on GETAC and STORA will not affect
02200 the status of anything marked in that accumulator.
02300 3. If the EXCHIN bit is set, we do an EXCHOP.
02400 4. If the INSIST bit is on, type conversions are performed.
02500 These conversions convert from the type specified in the
02600 TBITS word to the type specified in register B (bits
02700 passed to the INSISTer).
02800 5. If the ARITH bit is on, we make sure that the type is
02900 an arithmetic type, performing conversions if necessary.
03000
03100
03200 POST:
03300 1. Put the current contents of the ac's TBITS and SBITS
03400 down in the symbol table entry pointed to by PNT
03500 2. If the REM bit is set, do a REMOP on the thing in PNT
03600 3. If the BITS2 bit is set, we execute MOVE SBITS2,$SBITS(PNT2)
03700 This is useful when an operation on one argument of a binary
03800 op. may change the semantics of another.
03900 4. If the UNPROTECT bit is set, then register D is assumed to
04000 contain an ac number. The ac table entry is unprotected.
04100 5. If the EXCHOUT bit is set, we do an EXCHOP.
04200
04300 NOW FOR A DESCRIPTION OF THE ROUTINES WHICH ACTUALLY USE PRE AND POST:
04400
04500 CONV:
04600 This is really a no-op. It is here for the purposes of calling
04700 the type-conversion routines in PRE, and for the purpose of
04800 making sure that an argument is positive if in an accumulator
04900 (e.g. if we had CVF(-(A+B)), then the result would be in an
05000 accumulator in negated fashion. We now want to push it onto the
05100 stack for the call on CVF. We want to make sure it is REAL and
05200 positive. We use the POSIT bit: GENMOV (CONV,INSIST!POSIT,REAL)
05300
05400
05500 PUT
05600 This issues a store of accumulator mentioned in register D
05700 into the thing described in TBITS, SBITS, PNT. The accumulator
05800 table is updated to reflect this store (i.e. the thing talked about
05900 by PNT is marked as "inac").
06000
06100 If the PNT entry is a string, then D is assumed to be an ac.
06200 into which a HRROI was done, or the SP stack. At any rate, two
06300 POP's are emitted.
06400
06500 ACCESS:
06600 This routine makes sure that we can have access to the entry
06700 mentioned in PNT. That is, if the thing is indexed (result of
06800 an array calculation) and if it requires that some index accumulator
06900 be loaded with a good number, then the load will happen, so
07000 that an effective address can be generated which points at
07100 the thing talked about by PNT.
07200
07300 GET:
07400 This is the generalized "get this entity in an ac" routine.
07500 It makes many checks (i.e. is it already in an ac?) and
07600 finally returns in register D the number of the ac which
07700 has been loaded, and returns in SBITS the updated semantics
07800 information that now reflects the loaded state.
07900 (By the way, to "get" a string means to do HRROI ac,second word
08000 of string.. This is so that POP's can be done later). There
08100 are many modifier bits to this routine:
08200
08300 DBL -- make sure that the ac following the one loaded
08400 is free (for a double ac operation such as IDIV)
08500 INDX -- make sure entity is loaded in an AC which can be
08600 used for indexing (i.e. not 0 or 1. The reason
08700 for including 1 in this is a bit vague -- since
08800 runtime routines often return results in 1, we
08900 try to avoid its use for things thay may have
09000 to be stored as temps).
09100 SPAC -- load this into a special accumulator. That accumulator
09200 number is passed in D.
09300 ADDR -- load the address of this entity, not the value.
09400 POSIT -- make sure the entity is in the ac in positive form.
09500 NEGAT -- make sure in negative form.
09600 NONSTD -- if indxed temp, do not remop it as someone wants
09700 to use it again. (see SWPR for instance). The
09800 problem is not so much remopping, but that GET
09900 likes to make the semantic entries as "inac" on
10000 exit. This fouls up any index calculations that
10100 may have been stored in the PNT entity.
10200 MRK -- when done with the GET, call MARK (see below).
10300
10400 STACK:
10500 The entity mentioned in PNT is stacked on an appropriate
10600 stack. Strings (except arrays) are stacked on the SP
10700 stack, all others on the P stack. ADEPTH or SDEPTH is
10800 updated.
10900
11000 MARK:
11100 This uses the bits in TBITS and SBITS, and the ac number
11200 in D as prototypes for making up a temp descriptor, and
11300 marking the ac full with that temp. Return is a valid
11400 temp descriptor in PNT. If STRING is on in TBITS,
11500 a stacked-string descriptor will be generated
11600 (and of course, no accumulator will be marked).
11700 WARNING ***** MARK masks off some bits in SBITS and
11800 TBITS. PTRAC,CORTMP,INDXED,FIXARR are turned off in SBITS
11900 and the only bits honored by TBITS are:
12000 LPARRAY,SET,ITEM,ITMVAR,INTEGR,FLOTNG,STRING
12100
12200 SID
12300 ACCUMULATORS:
12400 FF -- RIGHT HALF SAVED.
12500 A --THIS MAY BE CHANGED
12600 B --SAVED, I BELIEVE.
12700 C --SAVED, I BELIEVE.
12800 D --OCCASIONALLY FILLED UP (E.G. GET,ACCESS)
12900 TBITS -- THESE ARE THE SEMANTIC BITS -- THEY MAY BE CHANGED.
13000 SBITS -- "
13100 PNT -- " (IN CASE OF MARK OR CONVERSIONS)
13200 LPSA CLOBBERED
13300 USER CLOBBERED
13400 TEMP CLOBBERED
13500 SP --SAVED
13600 SBITS2 --SAVED (modulo what is done in PRE).
13700 TBITS2 --SAVED
13800 PNT2 --SAVED
13900
14000 SEE GENMOV MACRO
14100 ⊗;
14200
00100 COMMENT ⊗CONV, PRE, POST -- Type-Conversion routines⊗
00200
00300 MASK←← 0+LPARRAY+SET+LSTBIT+ITEM+ITMVAR+INTEGR+FLOTNG+STRING!DBLPRC
00400 ;GENMOVE KNOWS ABOUT THESE TYPES
00500 REC <
00600 MASK ←← MASK+PNTVAR
00700 >;REC
00800
00900 ;THIS IS THE PREAMBLE FOR ALL OF THE ROUTINES WHICH
01000 ;USE DIRECTIVE BITS TO SPECIFY COERCIONS, EXCHOPS, ETC.
01100
01200 PREMASK ←← GETD!EXCHIN!INSIST!ARITH!PROTECT
01300
01400
01500 ↑↑CONV: TRNE FF,PREMASK
01600 PUSHJ P,PRE ;DO EVERYTHING HERE.
01700 TLNE SBITS,NEGAT ;IF NOT NEGAT OR
01800 TRNN FF,POSIT ;NOT NEED THINGS POSITIVE?
01900 JRST POST ;ALL DONE.
02000 JRST GETOPE ;DO THE GET.
02100
02200
02300
02400 PRE: TRNE FF,GETD ;DO A GETAD?
02500 PUSHJ P,GETAD ;YES
02600 TRNE FF,EXCHIN ;EXCHOP ON WAY IN?
02700 JRST [EXCHOP ;YES
02800 JRST .+1]
02900 TRNE FF,PROTECT
03000 JRST [HRROS ACKTAB(D) ;PROTECT THIS AC
03100 TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03200 TRNN TBITS,DBLPRC
03300 JRST .+1 ;THESE ARE NOT DOUBLE
03400 MOVEI TEMP,(D)
03500 CAIN TEMP,RF-1
03600 ERR <DRYROT PRE>,1
03700 CAIE TEMP,RF-1
03800 HRROS ACKTAB+1(D) ;2ND AC OF LONG
03900 JRST .+1]
04000 TRNN FF,INSIST!ARITH ;ANY COERCIONS TO DO?
04100 POPJ P, ;NO -- ALL DONE.
04200 PUSHJ P,QTYPCK
04300 ;CHECK FOR UNTYPED AND TYPE IF NEC. (SEE ERRORS)
04400 ;#IL# 7-8-72 RHT ! GET ACCESS BEFORE YOU CONVERT
04500 PUSHJ P,ACCOP ;GET ACCESS -- YOU MAY NEED IT
04600 TRNE FF,ARITH ;WANT TO BE SURE OF ARITH ARG?
04700 JRST AGET ;YES
04800 LEPPRE: TRNN TBITS,ITEM!ITMVAR ;IF EITHER HAS ITEM BITS ON.
04900 TRNE B,ITEM!ITMVAR ;ALL THESE ARE GOOD GUYS.
05000 JRST [ ;.... ;KEEP GOING.
05100 TRNE B,ITEM!ITMVAR
05200 TRNN TBITS,ITEM!ITMVAR
05300 ERR <ITEM TYPE MISMATCH >,1
05400 POPJ P,] ;THIS IS ALL THE CHECKING!
05500 TRNE B,SET ;A SET OR LIST DESIRED?
05600 JRST [TRNN TBITS,SET ;IF NOT LIST OR A SET CAN'T BE DONE
05700 ERR <TYPE CAN'T BE CONVERTED TO SET OR LIST>,1
05800 TRNE B,LSTBIT ;IF WANTED LIST CAN RETURN
05900 JRST MAKLST ;MAY HAVE TO COPY LIST.
06000 TRNN TBITS,LSTBIT ;IF WANTED SET AND HAVE SET CAN RETURN
06100 POPJ P,
06200 JRST MAKEST] ;WILL HAVE TO CALL CVSET
06300 ;;#YQ# JFR 2-2-77 DO RCLASS CHECKING FOR ASSIGNMENT NOW
06400 REC <
06500 TRNE TBITS,PNTVAR ;IF RECORDS & INSISTING
06600 TRNE TBITS,SHORT!ITEM!ITMVAR ;THEN BETTER BE SURE CLASSES MATCH
06700 JRST LEPP.1 ;NOT THAT CASE, ANYHOW
06800 PUSH P,PNT2 ;NOTE DON'T CHECK ITEMS
06900 PUSH P,LPSA
07000 HLRZ PNT2,$ACNO(PNT) ; THE CLASSID
07100 SKIPN LPSA,RCLASS ;
07200 ;; MWK This message used to be "RCLASS=0 ON INSISTING GET"
07300 ERR <ATTEMPT TO COERCE RECORD POINTER>,1
07400 PUSHJ P,SUBFOK ;CHECK CLASS ID
07500 ERR <CLASS DISAGREEMENT FOR RECORD COERCION>,1
07600 TRNN FF,MRK ;ASKED FOR A MARK
07700 SETZM RCLASS ;NO, ALWAYS CLEAR THIS OUT
07800 POP P,LPSA
07900 POP P,PNT2
08000 LEPP.1:
08100 >;REC
08200 ;;#YQ# ↑
08300 MOVEI TEMP,(TBITS) ;ALWAYS INSIST ON CORRECT PRECISION
08400 XORI TEMP,(B)
08500 TRNN TBITS,DBLPRC
08600 TRNE B,DBLPRC
08700 TRNN TEMP,DBLPRC ;ONE IS DBL. ARE BOTH?
08800 SKIPA TEMP,TBITS ;BOTH ARE SAME PRECISON
08900 JRST AGOTH ;DIFFERENT PRECISION. MUST CONVERT
09000 MOVE USER,B ;COPY OFF.
09100 AND TEMP,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
09200 ORCB USER,[XWD SBSCRP,MASK≠(ITEM!ITMVAR)]
09300 TDNN TEMP,USER ;ARE ALL BITS IN B ON IN TBITS?
09400 POPJ P, ;THEY MATCH !!
09500 AGOTH:
09600 PUSH P,FF
09700 TRZ FF,-1≠NONSTD ;IN CASE ANY OTHER ROUTINES CALLED.
09800 PUSH P,D
09900 TRNE B,INTEGR+FLOTNG
10000 JRST RESAR ;INSISTS ON ARITHMETIC TYPE
10100 TRNE B,STRING
10200 JRST RESSTR ;INSISTS ON STRING
10300 ERR <IMPOSSIBLE TYPE COERCION>,1
10400 JRST GEMGO ;GO ON ANYWAY
10500
00100
00200
00300 RESSTR: TRNN TBITS,INTEGR ;INSIST ON INTEGER ARGUMENT.
00400 ERR <STRINGS OF NON-INTEGERS?>
00500 TLNN TBITS,CNST ;CONSTANT?
00600 JRST STR1 ;NO
00700 EXCH SP,STPSAV ;GET A GOOD STACK POINTER.
00800 MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
00900 PUSH P,$VAL(PNT)
01000 PUSHJ P,PUTCH ;MAKE A STRING (SLOWLY)
01100 POP SP,PNAME+1
01200 POP SP,PNAME
01300 EXCH SP,STPSAV ;AND RESTORE EVERYONE.
01400 MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
01500 PUSHJ P,STRINS ;INSERT A STRING CONSTANT
01600 ;THIS DOES A GETAD.
01700 JRST GEMGO ;ALL DONE
01800
01900 STR1: ;PREPARE TO STACK THE INTEGER
02000 PUSHJ P,STACK1 ;DO THE STACK.
02100 SOS ADEPTH ;SINCE THE RUNTIM ROUTINES ADJUST.
02200 MOVEI TEMP,2
02300 ADDM TEMP,SDEPTH ;INCREASE DUE TO CALL.
02400 XCALL <PUTCH> ;FUNCTION CALL
02500 MOVEI SBITS,0 ;START WITH CLEAN DYNAMIC SLATE
02600 JRST TGO ;GO MAKE A TEMP.
02700
02800
02900
03000 ;;#SU# ! ADD PNTVAR TO THIS LIST
03100 AGET: TRNE TBITS,INTEGR+FLOTNG+PNTVAR ;IS IT ALREADY ARITHMETIC TYPE?
03200 POPJ P, ;YES
03300 PUSH P,FF
03400 TRZ FF,-1≠NONSTD ; SAVE ALL THIS FOR OTHER
03500 PUSH P,D ; EMBEDDED OPERATIONS
03600 MOVEI B,INTEGR ;THIS FOR THE BENEFIT OF ARSTR.
03700 RESAR: TRNE TBITS,STRING ;HERE TO GET ARITHMETIC RESULTS
03800 JRST ARSTR ;CONVERT FROM STRING
03900 TRNE TBITS,INTEGR+FLOTNG
04000 JRST FIXFL
04100 ERR <IMPOSSIBLE TYPE COERCION>,1
04200 JRST TGO ;MAKE A TEMP FOR IT ANYWAY...
04300
04400 ARSTR: TLNE TBITS,CNST ;CONSTANT?
04500 JRST STRCNS
04600 ;;#IA# 6-30-72 DCS (3-6) PROTECT PTRAC AC OVER GETAC
04700 HRLI PNT,-1 ;FLAG, ASSUME PROTECTION
04800 HRRZ TEMP,$ACNO(PNT) ;PTRAC AC #, IF ANY
04900 TLNN SBITS,PTRAC ;NEED PROTECTION?
05000 TLZA PNT,-1 ;NO, UNMARK
05100 HRROS ACKTAB(TEMP) ;YES, PROTECT
05200 ;;#IA# (3-6)
05300 PUSH P,B ;SAVE TYPE WORD
05400 PUSHJ P,GETAN0 ;NON-0 AC NUMBER
05500 JUMPGE PNT,.+3 ;NEED TO UNPROTECT?
05600 ;;#IA# 6-30-72 (4-6)
05700 HRRZ TEMP,$ACNO(PNT) ;YES, DO
05800 HRRZS ACKTAB(TEMP) ; IT
05900 ;;#IA# (4-6)
06000 MOVE A,[HRRZ LNWORD] ;CALCULATE LENGTH TO THIS AC
06100 PUSHJ P,STROP ;VIA STROP
06200 HRL B,PCNT ;SAVE PC FOR FIXUP
06300 HRLI C,0
06400 EMIT (<JUMPE USADDR!NORLC>) ;0 IF STRING EMPTY
06500 TLNE SBITS,STTEMP ;NO NEED TO COPY BP IF TEMP STRING
06600 JRST [MOVE A,[ILDB BPWORD]
06700 PUSHJ P,STROP ;SO DO ILDB DIRECTLY
06800 JRST NOCOP] ;AND GET OUT
06900 MOVE A,[MOVE BPWORD] ;GET COPY OF BP
07000 PUSHJ P,STROP ;IN SAME AC
07100 HRL C,D
07200 EMIT (<ILDB USADDR!NORLC>) ;ILDB AC,AC
07300 NOCOP: HRR B,PCNT ;FIXUP WORD
07400 PUSHJ P,FBOUT
07500 MOVEI A,UNDO!REM
07600 PUSHJ P,STROP ;NOW ISSUE SUB IF NECESSARY
07700 PUSHJ P,MARKINT ;MARK INT. RETS RIGHT THING IN PNT
07800 POP P,B
07900 TRNE B,INTEGR ;CONVERT ONLY TO INTEGER?
08000 JRST GEMGO ;YES, OK.
08100 JRST FIXFL ;GO ON FARTHER
08200
00100
00200 STRCNS: HRRZ TEMP,$PNAME(PNT) ;THIS IS THE SAME CODE AS
00300 JUMPE TEMP,.+3 ; SAIL GENERATES TO DO
00400 MOVE TEMP,$PNAME+1(PNT) ; STRING to INTEGER AT
00500 ILDB TEMP,TEMP ; RUNTIME
00600 TRNN B,INTEGR ;DOES HE WANT AN INTEGER CONST
00700 FLOAT TEMP,TEMP ;NO -- ASSUME FLOATING
00800 JRST CONGO ;GO INSERT A CONSTANT.
00900
01000 FIXFL:
01100 TRNN TBITS,DBLPRC ;INPUT LONG?
01200 JRST FXFLS1 ;NO
01300 EXCH B,-1(P) ;ULTIMATE DESIRES
01400 MOVEI TEMP,FXFLL1 ;RETURN ADDR
01500 EXCH TEMP,(P)
01600 PUSH P,B ;ORIGINAL DIRECTIVE BITS
01700 PUSH P,TEMP ;OLD AC D
01800 MOVSI A,(<SNGL>) ;WHAT TO EMIT, IF WE HAVE TO
01900 MOVEI B,FLOTNG ;WHAT WE WANT, TEMPORARILY
02000 TLNN TBITS,CNST
02100 JRST UUOGO ;CONVERT TO SINGLE REAL, COME BACK TO FXFLL1
02200 SNGL TEMP,$VAL(PNT) ;DO THE OP ON A CONSTANT
02300 JRST CONGO ;RECORD RESULTS
02400 FXFLL1: POP P,B ;ULTIMATE DESIRES ARE BACK
02500 JRST LEPPRE ;PROBLEM HAS BEEN REDUCED ONE NOTCH
02600
02700 FXFLS1:
02800 TRNN B,DBLPRC ;OUTPUT LONG?
02900 JRST FXFLS2 ;NO
03000 TLNE TBITS,CNST ;CONSTANT?
03100 JRST [MOVE TEMP,$VAL(PNT) ;YES, GET VALUE
03200 ;;#YB# ! JFR 1-3-77 COMPLETE TYPO
03300 TRNN TBITS,FLOTNG ;ALREADY REAL?
03400 FLOAT TEMP,TEMP ;NO
03500 SETZM DBLVAL ;SECOND WORD IS ZERO
03600 JRST CONGO] ;THE EASY WAY
03700 GENMOV (GET,DBL!INSIST,FLOTNG) ;LOAD IT FLOTNG
03800 PUSHJ P,CLEARA ;THEN FORGET YOU DID IT
03900 MOVE FF,-1(P) ;ORIGINAL DIRECTIVE BITS
04000 IORI B,DBLPRC
04100 ADDI D,1 ;AND ZERO THE NEXT
04200 FXFLL2: EMIT (<SETZ NOADDR>)
04300 SOJA D,TGO1 ;MARK RESULT
04400 FXFLS2:
04500 ;;%DN% JFR 7-1-76
04600 MOVE TEMP,ASWITCH ;OPTION BITS
04700 MOVSI A,(<FIX>) ;ASSUME STANDARD
04800 TRNE TEMP,AFIXR
04900 MOVSI A,(<FIXR>)
05000 TRNE TEMP,AKIFIX
05100 MOVSI A,(<KIFIX>)
05200 MOVE USER,A ;COPY THE DECISION
05300 OR USER,[TEMP,TEMP] ;INSERT AC AND ADDR FIELDS
05400 ;;%DN% ↑
05500 MOVE TEMP,TBITS ;GET OR OF `SHORT' BITS
05600 OR TEMP,B
05700 TRNE B,INTEGR ;RESULT FIXED?
05800 JRST FIX ;YES
05900 ;;%DN%
06000 MOVE TEMP,ASWITCH
06100 MOVSI A,(<FLOAT>)
06200 TRNE TEMP,AFLTR
06300 MOVSI A,(<FLTR>)
06400 MOVE USER,A
06500 OR USER,[TEMP,TEMP]
06600 MOVE TEMP,TBITS ;GET OR OF `SHORT' BITS
06700 OR TEMP,B
06800 ;;%DN% ↑
06900 TLNE TBITS,CNST ;CONSTANT?
07000 JRST FLC
07100 TRNN TEMP,SHORT ;SHORT INTEGER BEGIN FLOATED?
07200 JRST UUOGO ;NO, USE UUO
07300 PUSH P,[FSC USADDR!NORLC] ;INSTR TO FLOAT
07400 HRLI C,233 ;ARGUMENT OF FLOAT INSTR
07500 SHRTCV: MOVE TEMP,-2(P) ;FF BITS COMING INTO TOTAL
07600 TRNE TEMP,SPAC ;WAS SPECIFIC AC REQUIRED
07700 TRO FF,SPAC ;YES, RETAIN IT
07800 PUSHJ P,GET ;GET THE THING
07900 POP P,A ;INSTR
08000 JRST JSTEST ;ALREADY KNOW WHAT AC
08100
08200
08300 FIX: TLNE TBITS,CNST ;CONSTANT?
08400 JRST FLC
08500 NOEXPO<
08600 TRNN TEMP,SHORT ;CONVERT TO SHORT INTEGER?
08700 JRST UUOGO ;NO
08800 PUSH P,[PDPFIX USADDR!NORLC] ;YES, USE PDP-10 INSTR
08900 HRLI C,233000 ;MAGIC ADDR FIELD FOR PDPFIX INSTR
09000 JRST SHRTCV ;DO SHORT CONVERSION
09100 >;NOEXPO
09200
09300 UUOGO: MOVE TEMP,-1(P) ;DIRECTIVE BITS WORD FROM STACK.
09400 TRNE TEMP,SPAC ;IS HE GOING TO WANT A SPECIAL ONE?
09500 JRST JSTEST ;YES
09600 HRR D,$ACNO(PNT)
09700 ;;#IA# 6-30-72 DCS (5-6) PROTECT PTRAC AC OVER GETAC
09800 HRLI PNT,-1 ;FLAG, ETC., SEE PART (3-6)
09900 TLNN SBITS,PTRAC
10000 TLZA PNT,-1
10100 HRROS ACKTAB(D)
10200 ;;#IA# (5-6)
10300 TLNN SBITS,INAC ;IF NOT IN AN AC, THEN GET ONE.
10400 PUSHJ P,GETAC
10500 ;;#IA# 6-30-72 (6-6)
10600 JUMPGE PNT,.+3
10700 HRRZ TEMP,$ACNO(PNT)
10800 HRRZS ACKTAB(TEMP)
10900 ;;#IA# (6-6)
11000 GOTACB:
11100 JSTEST:
11200 DPB D,[POINT 4,A,12] ; STORE AC NUMBER IN INSTRUCTION.
11300 PUSHJ P,EMITER
11400 TGO1: HRRZ TEMP,FF ;ORIGINAL FF
11500 TRNE TEMP,NONSTD ;IF NON-STANDARD (SEE SWAP OPER),
11600 JRST [POP P,(P) ; DON'T REMOP OR MARK
11700 JRST GEMGO1] ;BUT RETAIN THE AC USED
11800 PUSHJ P,REMOP ;REMOP THE OPERAND.
11900 TGO: HRRZ TBITS,B ;MAKE TBITS CONFORM TO THE DESIRED TYPE
12000 ANDI TBITS,MASK ;MAKE RESULT LOOK LIKE THE REQUESTS
12100 TLZ SBITS,-1≠NEGAT ;CLEAR AWAY THE CHAFF
12200 PUSHJ P,MARK1 ;GO DO A MARK.
12300 JRST GEMGO
12400
12500 FLC: MOVE TEMP,$VAL(PNT) ;HERE FOR A CONSTANT.
12600 XCT USER ;DO THE CONVERSION
12700 CONGO: MOVEM TEMP,SCNVAL ;SET UP FOR SYMBOL TABLE INSERTION
12800 HRRZ TBITS,B ;COME HERE TO INSERT A CONSTANT.
12900 ANDI TBITS,MASK
13000 TLO TBITS,CNST
13100 MOVEM TBITS,BITS ;FOR CONINS
13200 PUSHJ P,REMOP ;ALWAYS REMOVE THE OLD GUY
13300 PUSHJ P,CONINS
13400 GEMGO: POP P,D
13500 GEMGO1: POP P,FF ;AT LAST DO THE POP AND
13600 POPJ P, ;ALL DONE -- FULL SPEED AHEAD.
13700
00100
00200 ; NOW FOR THE POSTAMBLE (WE WILL AMBLE THROUGH THE COMPILATION).
00300
00400
00500 ↑↑POST: MOVEM SBITS,$SBITS(PNT) ;PUT DOWN SEMANTICS WORDS.
00600 MOVEM TBITS,$TBITS(PNT)
00700 TRNN FF,EXCHOUT!BITS2!REM!UNPROTECT ;THESE ARE THINGS TO DO.
00800 POPJ P, ;ALL DONE.
00900 TRNE FF,REM ;REMOP THE THING?
01000 JRST [PUSHJ P,REMOP ;YES
01100 MOVE SBITS,$SBITS(PNT)
01200 JRST .+1]
01300 TRNE FF,BITS2 ;UPDATE SBITS2?
01400 MOVE SBITS2,$SBITS2(PNT2) ;DONE.
01500
01600 TRNE FF,UNPROTECT
01700 JRST [HRRZS ACKTAB(D)
01800 TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
01900 TRNN TBITS,DBLPRC
02000 JRST .+1
02100 MOVEI TEMP,(D)
02200 CAIN TEMP,RF-1
02300 ERR <DRYROT POST>,1
02400 CAIE TEMP,RF-1
02500 HRRZS ACKTAB+1(D)
02600 JRST .+1]
02700
02800 TRNN FF,EXCHOUT ;EXCHANGE ON WAY OUT?
02900 POPJ P, ;NO --DONE.
03000 EXCHOP
03100 POPJ P,
03200
00100 COMMENT ⊗PUT⊗
00200
00300 ↑↑PUT: TRNE FF,PREMASK ;ANY PREAMBLE TO BE DONE
00400 PUSHJ P,PRE ;YES -- DO IT.
00500 PUSH P,FF ;HERE TO STORE AN ACCUMULATOR INTO
00600 ; HAVE PUT ALWAYS DO AN ACCESS
00700 ; TLNE SBITS,INDXED ;A DESCRIPTOR
00800 PUSHJ P,ACCOP ;GET ACCESS TO THE TARGET.
00900 TRNE TBITS,STRING ;IF NOT A STRING
01000 TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;OR NOT REALLY A STRING,THEN
01100 JRST APUT ;USE A MOVEM OR THE LIKE.
01200
01300 MOVE A,[POP BPWORD!LNWORD!SBOP!BPFIRST]
01400 PUSHJ P,STROP ;USE THE STRING OPERATION TO PUT OUT POPS.
01500 CAIE D,RSP ;IF IT WAS NOT THE STACK, THEN
01600 PUSHJ P,CLEARA ;CLEAR OUT THIS ACCUMULATOR ENTRY.
01700 ;IT WAS CHANGED WHEN THE POPS WERE DONE ANYWAY.
01800 JRST PUTFIN ;ALL DONE. MY THAT WAS SIMPLE.
01900
02000 APUT: PUSHJ P,CLEARA ;CLEAR OUT THE DESTINATION ACCUMULATOR.
02100 TLNE SBITS,INAC ;IF THE DESTINATION OF THE STORE IS ALREADY
02200 PUSHJ P,CLEAR ;IN AN AC, THEN CLEAR IT OUT.
02300 REC <
02400 NORGC <
02500 TRNE TBITS,PNTVAR ;A RECORD ?
02600 TRNE TBITS,777777-(PNTVAR!GLOBL)
02700 JRST APUT2 ;NOPE, JUST DO THE PUT
02800 PUSH P,C ;IT MAY BE USED, NOT SURE
02900 MOVNI C,1 ;DEREFERENCE THE THING IN PNT
03000 PUSHJ P,RFCADJ ;LIKE SO
03100 POP P,C
03200
03300 APUT2:
03400 >;NORGC
03500 >;REC
03600 HRLZI A,(<MOVEM>) ;THE ORDINARY STORE INSTRUCTION.
03700 TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03800 JRST .+3 ;SUFFICES IN ANY CASE FOR AN ARRAY, ITEM, ITEMVAR
03900 TRNE TBITS,DBLPRC
04000 HRLZI A,(<DMOVEM>)
04100 TLNN SBITS,NEGAT ; BUT IF NEGATED, USE THE OTHER
04200 JRST .+4 ;NOT NEGATED
04300 TRNN TBITS,DBLPRC ;DOUBLE?
04400 TLCA A,(<MOVNM>≠<MOVEM>) ;NO. MAKE INTO MOVNM
04500 TLC A,(<DMOVNM>≠<DMOVEM>) ;YES. MAKE INTO DMOVNM
04600 ;; #OX# TREAT ? ITEMVARS SPECIALLY
04700 TLNE TBITS,MPBIND
04800 JRST [HRR C,D ;SAVE AC NUMBER
04900 GENMOVE (GET,ADDR!INDX)
05000 MOVSS D
05100 HRR D,C ;XWD INDX,,AC
05200 MOVE A,[MOVEM USX+NORLC+NOADDR]
05300 JRST .+1
05400 ] ;GO AWAY
05500 ;; #OX#
05600 PUSHJ P,EMITER ;AND PUT OUT THE INSTRUCTION.
05700
05800 TLNE SBITS,INDXED ;WE DO NOT WANT TO MARK *********
05900 JRST PUTFN1 ;GO AWAY.
06000
06100 HRRM D,$ACNO(PNT) ;AND THE AC IT IS IN
06200 HRRM PNT,ACKTAB(D) ;IN TWO PLACES.
06300 ;THIS UNPROTECTS THIS ACCUMULATOR.
06400 TLNN SBITS,PTRAC
06500 TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
06600 JRST .+3
06700 TRNE TBITS,DBLPRC
06800 JRST [SKIPE ACKTAB+1(D)
06900 ERR <DRYROT PUT DOUBLE>,1
07000 MOVEI TEMP,(D)
07100 CAIE TEMP,RF-1 ;DO NOT CLOBBER RF!
07200 HRRM PNT,ACKTAB+1(D)
07300 JRST .+1]
07400 TLOA SBITS,INAC ;AND NOW MARK THE DESCRIPTOR BITS
07500
07600 PUTFN1: TLZ SBITS,NEGAT ;SUBSCRIPTED, NEGAT GETS IN WAY (BELIEVE!)
07700 PUTFIN: POP P,FF ;ALL DONE
07800 JRST POST ;AND FINISH OUT.
07900
00100 COMMENT ⊗ACCESS,GETSDR,GETDR,DISBLK,ZOTDIS--last four only for dis
00200
00300 Call ACCOP when you need to reference a thing and don't know whether you
00400 can get at it in a single instruction (i.e. an indexed thing).
00500 GENMOV(ACCESS) will cause ACCOP to be called for you.
00600 People like GET and STACKOP do it automatically.
00700 ⊗
00800
00900 ↑↑ACCESS: TRNE FF,PREMASK
01000 PUSHJ P,PRE
01100 PUSHJ P,ACCOP
01200 JRST POST
01300
01400 ACCOP: TDNN SBITS,[XWD INDXED,DLFLDM]; ONLY CARE IF INDEXED OR NEED A DISPLY
01500 POPJ P,
01600 TLNE SBITS,INAC!PTRAC ;IF IN AN AC WE CAN ACCESS IT
01700 POPJ P,
01800 TRNN SBITS,DLFLDM ;IF DISPLAY LEV=0 ONLY CARE ABOUT INDEXED
01900 JRST INXSTF ;NO WORRY ABOUT THE DIAPLAY
02000 LDB TEMP,[LEVPOINT<SBITS>] ;PICK UP DISPLY LEV
02100 TRNE TBITS,STRING ;IS ITT A STRING
02200 JRST [
02300 ;; #JR# BY JRL 10-17-72 ITEMVARS,ARRAYS DON'T USE STRING STACK
02400 TDNN TBITS,[REFRNC!SBSCRP,,ITEM!ITMVAR];THESE THINGS DON'T USE
02500 TLNE SBITS,INDXED ;INDEXED? ;STRING STACK
02600 JRST .+1
02700 ;; #JR#
02800 JRST GETSDR ;GET STRING DR
02900 ]
03000 PUSHJ P,GETDR ;GET A DISPLAY REG LOADED
03100 ;;%DU% JFR 1-4-77
03200 TRNE FF,ACESS2 ;DIRECT TO 2ND WD
03300 TRNN TBITS,DBLPRC ; OF LONG?
03400 JRST ACCOP1 ;NO
03500 TLNE TBITS,REFRNC
03600 JRST ACMOP ;APPARENTLY ONLY REF. FORMALS NEED THIS
03700 ACCOP1:
03800 ;;%DU% ↑
03900 TRNN SBITS,INDXED ;INDEXED TOO?
04000 POPJ P, ;NO
04100 INXSTF:
04200 ;;#JR#
04300 TRNN TBITS,ITEM!ITMVAR
04400 TRNN TBITS,STRING ;ALWAYS NEED STRING GUYS
04500 JRST .+2
04600 ;;#JR#
04700 JRST ACMOP
04800 HRRZ TEMP,$VAL(PNT) ; ONLY NEED IT IF NON-ZERO
04900 JUMPE TEMP,CPOPJ ; DISPLACEMENT
05000
05100 ACMOP: TLNE SBITS,PTRAC ;IS IT ALREADY ACCEPTABLE (IN AC)?
05200 POPJ P, ; YES, WHY HAVE WE WORRIED?
05300
05400 PUSH P,D ;HAVE TO SAVE CURRENT AC
05500 PUSH P,A
05600 PUSH P,FF
05700 MOVE TEMP,FF
05800 HRRI FF,INDX ;SO THAT NOTHING NONSTD WILL HAPPEN.
05900 MOVE A,[XWD 40!2!1,ADDR] ;SET NECESSARY BITS
06000 ;(SPECIAL BIT, MOVE, GET AC, USE INDXBLE AC, GET ADDR)
06100 ;;%DU%
06200 TRNE TEMP,ACESS2
06300 TRNN TBITS,DBLPRC
06400 CAIA
06500 TLO A,400 ;DO NOT CHANGE SBITS(PNT)
06600 ;;%DU% ↑
06700 PUSHJ P,GETWD
06800 POP P,FF
06900 ;;%DU% JFR 1-4-77
07000 TRNE FF,ACESS2
07100 TRNN TBITS,DBLPRC
07200 JRST ACMOP1 ;NOT SPECIAL 2ND WD ACCESS
07300 PUSH P,TBITS
07400 SETZB TBITS,SBITS
07500 PUSHJ P,GETTEM ;WE HAVE GOTTEN THE ADDR INTO A TEMP
07600 MOVEM D,$ACNO(LPSA) ;REMEMBER INTO WHICH AC
07700 HRRM LPSA,ACKTAB(D)
07800 POP P,$TBITS(LPSA)
07900 HRRZS TBITS,$TBITS(LPSA) ;SANITIZE THE TYPE
08000 MOVSI SBITS,ARTEMP!PTRAC!INDXED
08100 MOVEM SBITS,$SBITS(LPSA)
08200 SETZM $VAL(LPSA) ;DISPLACEMENT IS ZERO
08300 MOVEI PNT,(LPSA) ;OUR NEW OPERAND
08400 ACMOP1:
08500 ;;%DU% ↑
08600 POP P,A
08700 POP P,D
08800 POPJ P,
08900
09000
09100 COMMENT⊗
09200 DSCR GETSDR,GETDR
09300 DES ROUTINES TO LOAD UP STRING (ARITHMETIC) DISPLAYS
09400 LOADS UP LPSA WITH THE AC NO TO USE & FIXES UP ACTAB,DISTAB,&DISLST
09500 PARM TEMP=LEVEL DESIRED
09600 SID MANGLE TEMP,LPSA
09700 STORES LEVEL IN LSDRLV, STORES DR # IN LSDRNM (LH FOR SDR & RH FOR DR)
09800 ⊗
09900
10000 ;;#MN# 7-13-73 FIX ACCESS PROBLEM
10100 ZERODATA(EMITTER DATA)
10200 LSDRLV: 0 ;SEE ABOVE
10300 LSDRNM: 0
10400 ENDDATA
10500
10600 ↑↑GETSDR:
10700 HRLM TEMP,LSDRLV ;REMEMBER LEVEL OF STRING REQUEST
10800 HLRZ LPSA,DISTAB(TEMP) ;DO WE HAVE IT ALREADY
10900 HRLM LPSA,LSDRNM ;IF SO REMEMBER
11000 ;;#MN#
11100 JUMPN LPSA,CPOPJ ;YES
11200 PUSHJ P,GETDR ;GET THE P-DISPLY
11300 PUSH P,FF ;WHAT A PITY WE MIGHT HAVE JUST POPPED
11400 PUSH P,A ;BUT THIS IS QUICKER IN THE LONG
11500 PUSH P,B ;RUN THAN MESSING WITH FLAGS
11600 PUSH P,C ;
11700 PUSH P,D
11800 TRZ FF,DBL ;ONLY ONE AC
11900 HRL D,LPSA ;USE P-DR AS INDEX
12000 MOVE B,TEMP ;WE WILL NEED THIS
12100 HRLI C,2 ;DISPL OF 2
12200 PUSHJ P,GETAN0 ;GET AN AC FOR DISPLY
12300 EMIT (<MOVE ,USX!USADDR!NORLC>) ;LOAD THE DR
12400 HRLM D,DISTAB(B) ;ENTER INTO DISPLAY TABLE
12500 PUSHJ P,DISBLK ;SET UP MOST OF BLOCK
12600 MOVEI TEMP,STRING ;
12700 HRRZM TEMP,$TBITS(LPSA) ;MAKE TYPE RIGHT
12800 MOVSS $VAL(LPSA) ;FIX UP AND MASK
12900 ;;#MN# !
13000 HRLM LPSA,LSDRNM
13100
13200 JRST RETSEQ ;GO POP STUFF & RETURN
13300 ↑↑GETDR:
13400 ;;#MN# !
13500 HRRM TEMP,LSDRLV
13600 HRRZ LPSA,DISTAB(TEMP) ;PICK UP THE PUTATIVE REGISTER
13700 ;;#MN# !
13800 HRRM LPSA,LSDRNM
13900 JUMPN LPSA,CPOPJ ;IF THERE,RETURN
14000 PUSH P,FF
14100 PUSH P,A
14200 PUSH P,B
14300 PUSH P,C
14400 PUSH P,D
14500 PUSH P,TEMP ;GETDR MUST SAVE IT
14600 TRZ FF,DBL ;ONLY ONE AC
14700 HRRZI B,1(TEMP) ;NEXT LEVEL DEEPER
14800
14900 GDR1: HRLZ D,DISTAB(B) ;PICK IT UP
15000 CAIN D,0 ;IS IT LOADED
15100 AOJA B,GDR1 ;NO
15200 HRLI C,1 ;SET TO SELECT STATIC LINK
15300 MOVE A,[<MOVE 0,USX!NORLC!USADDR>]
15400 GDR2: PUSHJ P,GETAN0 ;THIS BETTER LEAVE LH(D) ALONE -- IT DOES
15500 PUSHJ P,EMITER ;UP ONE STATIC LINK
15600 SOS B ;BACK A LEVEL
15700 HRRM D,DISTAB(B) ;SAY WE HAVE IT
15800 PUSHJ P,DISBLK ;TO DO STUFF FOR DISPLAY BLOCK&ACKTAB
15900 CAMN B,(P) ;IS THIS THE ONE WE WANT
16000 JRST GDR4 ;YES
16100 GDR3: HRL D,D ;USE AS INDEX PERHAPS
16200 HRR D,DISTAB-1(B) ;NEXT AC BACK
16300 TRNE D,-1 ;IS IT THERE
16400 SOJA B,GDR3 ;YES
16500 JRST GDR2 ;NO--FETCH IT
16600 GDR4: HRRZ LPSA,D ;AC NO OD DISPLY
16700 ;;#MN# !
16800 HRRM LPSA,LSDRNM ;REMEMBER NUMBER
16900 POP P,TEMP
17000 ;;#UW# ! JFR 8-17-75 CALL TO EMITER AT GDR2+1 WIPED OUT LSDRLV
17100 HRRM TEMP,LSDRLV
17200 RETSEQ: POP P,D
17300 POP P,C
17400 POP P,B
17500 POP P,A
17600 POP P,FF
17700 POPJ P, ;RETURN
17800
17900 COMMENT ⊗
18000 DSCR DISBLK
18100 DES THIS PROCEDURE SETS UP DISPLAY SEMBLK STUFF & UPDATES ACKTAB
18200 IT SETS LPSA TO POINT ATE THE NEW SEMBLK
18300 THE BLOCK IS SET UP FOR A LPSA TYPE SEMBLK
18400 PARM B = DISPLAY LEBEL
18500 D= ACNO OF DISPLAY REG
18600 ⊗
18700 ↑↑DISBLK:
18800 GETBLK ;GET A BLOCK
18900 HRRM D,$ACNO(LPSA) ;SAVE AC NO
19000 HRRM B,$ADR(LPSA) ;LEVEL GOES HERE
19100 SETOM TEMP
19200 HRLZM TEMP,$VAL(LPSA) ;SETS UP ANDING MASK
19300 MOVE TEMP,[XWD PTRAC!INAC!DISTMP,INTEGR]
19400 HRRZM TEMP,$TBITS(LPSA) ;$TBITS WORD
19500 HLLZM TEMP,$SBITS(LPSA) ;$SBITS WORD
19600 PUSHJ P,RNGDIS ;PUT IT ON DISLST LIST
19700 HRRZM LPSA,ACKTAB(D) ;MARK AC FULL OF IT
19800 POPJ P, ;RETURN
19900
20000 COMMENT ⊗
20100 DSCR ZOTDIS
20200 DES this procedure will wipe out your current display
20300 PARM None
20400 SID LPSA,TEMP used
20500 ⊗
20600 ↑↑ZOTDIS:
20700 PUSH P,D ;SAVE
20800 PUSH P,A
20900 MOVE A,CDLEV ;CURRENT DISPLAY LEVEL
21000 ZDIS.1: SOJL A,ZDIS.2
21100 HRRZ D,DISTAB+1(A)
21200 CAIE D,RF ;DONT ZONK RF
21300 CAIN D, ;DONT DO ANYTHING IF NOT THERE
21400 SKIPA
21500 PUSHJ P,STORZ
21600 HLRZ D,DISTAB+1(A)
21700 CAILE D,
21800 PUSHJ P,STORZ
21900 SETZM DISTAB+1(A)
22000 JRST ZDIS.1
22100 ZDIS.2: POP P,A
22200 POP P,D
22300 POPJ P,
22400
22500
22600
00100 COMMENT ⊗GET
00200
00300 GENMOV(GET) generally invokes this routine.
00400 It has many purposes, depending on the entity to be "getted".
00500 Briefly, however, it loads an AC with the thing one
00600 wants in order to store or compute using the entity in
00700 question. For strings, it loads a string address
00800 with the left half negative (for popping). For
00900 INDXED guys (with ADDR turned on), it loads
01000 the result of the index calc to an ac if it was not
01100 there. For regular variables, it simply picks them
01200 up if they are not in an AC. The bits
01300 ADDR, INDX, DBL, POSIT, NEGAT, and MARK
01400 may be used to modify the action of GETOPE.
01500
01600 ⊗
01700
01800 ↑↑GET: TRNE FF,PREMASK ;ANYTHING TO DO??
01900 PUSHJ P,PRE
02000 TRC FF,INSIST!NONSTD ;IF NO MARKING TO BE DONE, AND
02100 TRCE FF,INSIST!NONSTD ; A TYPE CONVERSION WAS DONE,
02200 JRST GETOPE
02300 ;; #OZ# (1 OF 1) PRE DOESN'T DO A GET OF ITEMS OR ITEMVARS
02400 TRNE B,ITMVAR!ITEM ; PRE DID NOT DO A GET
02500 ; IF ITEMVARS OR ITEMS
02600 JRST GETOPE
02700 ;; #OZ#
02800 HRRZ TEMP,B ; (COMPARE INSISTED TYPE WITH
02900 CAIE TEMP,(TBITS) ; ACTUAL TYPE), THEN DON'T GET
03000 JRST POST ; AGAIN
03100 ↑GETOPE:
03200 PUSHJ P,ACCOP ; ESTABLISH ACCESS TO THE EFFECTIVE ADDRESS.
03300
03400 COMMENT ⊗ IF STTEMP, NO MORE WORK NECESSARY
03500 (ASSUME STRING IS ON) ⊗
03600
03700 TLNN SBITS,STTEMP
03800 JRST GETOPC
03900 TRNN FF,ADDR ;MUST GO THRU WITH IT IF ADDR
04000 JRST TMPRET
04100
04200 COMMENT ⊗ USE LEFT HALF OF A TO HOLD SOME EXTRA BITS:
04300
04400 1 -- NEED AN AC (GETAC)
04500 2 -- DO A MOVE OF SOME SORT
04600 4 -- DO A MOVN
04700 10 - MAKE IT A HRRO
04800 20 - MAKE IT A HRROI, FOR STRING INDXED GUYS (SEE BELOW)
04900 40 - SPECIAL ACCOP BIT, SEE GETRET BELOW
05000 100 - SEEMS TO MEAN MOVEI -- WASN'T DOCUMENTED, DAMMIT
05100 200 - SPECIAL KLUGERY FOR RECORDS
05200 400 - KLUGE TO PREVENT GET ADDR OF REGULAR THING
05300 FROM MARKING INAC.
05400 1000 - USE DOUBLE WORD INSTRUCTIONS (DMOVE, ...) INSTEAD OF SINGLE (MOVE,...)
05500
05600 NEED EXTRA CHECKS IF ENTITY IS ALREADY IN AN AC
05700 ⊗
05800
05900 GETOPC: HRLZI A,3 ;ASSUME NEED A MOVE
06000 TRNE FF,SPAC ;UNLESS AC # PROVIDED,
06100 TLZ A,1 ; ASSUME AC NEEDED
06200 TLNN SBITS,INDXED ;IF ¬INDEXED, THEN TURN OFF NONSTD.
06300 TRZ FF,NONSTD ;SO AS NOT TO FOUL UP.
06400 REC <
06500 TRNE TBITS,PNTVAR ;MAKE SURE ONLY DO KLUGE IF A RECORD
06600 TRNE TBITS,777777-(PNTVAR!GLOBL) ;ONLY THAT BIT IS ALLOWED TO BE ON
06700 JRST NOSPAC ; NOT A RECORD
06800
06900 ;;#SA# ! GET ADDR IS JUST NORMAL
07000 TRNE FF,ADDR ;WELL??
07100 JRST NOSPAC
07200
07300 HLRZ TEMP,$ACNO(PNT) ;IN CASE WE WANT A MARK (USUALLY WILL)
07400 TRNE FF,MRK ;TEST IT OUT
07500 HRRZM TEMP,RCLASS ;NOW THE MARK WON'T DRYROT
07600 TLNE TBITS,CNST ;CONSTANTS ARE GETTABLE DIRECTLY
07700 JRST [ CAME PNT,NLRCBK ;THIS SHOULD BE THE ONLY ONE POSSIBLE
07800 ERR <RECORD CLASS TEMP OTHER THAN NULL RECORD?>,1
07900 JRST NOSPAC
08000 ]
08100
08200 TLNN SBITS,ARTEMP ;IF NOT A TEMP
08300 JRST RECKL1 ;THEN DO THE FIRST PART OF RECORD KLUGE
08400 TLNN SBITS,INDXED ;IF NOT INDEXED TEMP BUT A TEMP
08500 JRST NOSPAC ;DON'T DO ANYTHING ABOUT THIS
08600 ;WE WILL PERFORM THE INCREMENT OF
08700 ;THE REF CNT FOR ANY VARIABLE OR
08800 ;INDXED TEMP, WHETHER A SUBFIELD OR NOT
08900 RECKL1:
09000 NORGC <
09100 TLO A,200 ;BIT THAT SAYS TO DO RECORD ACCESS
09200 >;NORGC
09300 TRNN FF,SPAC ;KLUGE TO GET AC # GOOD
09400 TRO FF,INDX ;IF WE GET ONE, IT BETTER BE INDEXABLE
09500
09600 IFN 0,<
09700 TLNE SBITS,INAC ;IF INAC, WE WILL FORGET IT FOR THIS PURPOSE
09800 PUSHJ P,[ TLNE SBITS,INDXED ;BIG SURPRIZE IF THIS IS ON
09900 ERR <DRYROT: INDXED INAC?>,1
10000 ;;#SV# RHT MUST PRESERVE D
10100 PUSH P,D
10200 HRR D,$ACNO(PNT) ;GET OUT OF THE AC & THEN WILL WIN
10300 PUSHJ P,CLEARA ;FORGET INACITUDE
10400 POP P,D
10500 JRST GETAD ;REFURBISH THE BITS & RETURN FROM LITERAL
10600 ]
10700 >;FALSE
10800
10900 ;; FALL INTO NOSPAC
11000 >;REC
11100 NOSPAC: TLNN SBITS,INAC!PTRAC;IF IN AC, HAVE TO BE SURE IT'S RIGHT
11200 JRST STCHK ; IF NOT, MUST CHECK
11300 ; FOR STRINGS (HAVE TO LOAD)
11400
11500 ;DBLPRC PTRAC MUST TURN ON DBL UNLESS ADDR
11600 TRNN FF,ADDR
11700 TLNN SBITS,PTRAC
11800 JRST NOSPA1
11900 TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
12000 TRNN TBITS,DBLPRC
12100 JRST NOSPA1
12200 IORI FF,DBL
12300 NOSPA1:
00100
00200 Comment ⊗ INAC -- if DBL or INDX or SPAC,
00300 find out if thing can stay in this AC -- otherwise
00400 must get another. ⊗
00500
00600 ; FIRST CHECK SPAC GUYS
00700
00800 TLZ A,1!2 ;ASSUME NOTHING YET
00900 TRNN FF,SPAC ;PROVIDED WITH SPECIFIC AC?
01000 JRST DBCHK ; NO, CHECK DBL WANTED
01100 HRRZ TEMP,$ACNO(PNT) ;GET CURRENT AC #
01200 CAIN TEMP,(D) ;DID WE LUCK OUT (SAME ONE)?
01300 JRST SBSCHK ;YES, GO CHECK SPECIAL INDXED THING
01400
01500 ;DCS 8/16/70 IF SPAC AC BEING REPLACED,
01600 ; STORE AND CLEAR WHAT'S IN IT
01700 SKIPLE ACKTAB(D) ;PROTECTED OR NOTHING THERE?
01800 PUSHJ P,STORZ ; NO, GET RID OF IT
01900 ;DCS 8/16/70
02000
02100 TLO A,2 ;WILL HAVE TO DO A MOVE
02200 JRST WPCHK1 ;AND MAKE SEMANTICS CHANGES
02300
02400 ; IF DBL IS ON, SEE IF NEXT AC IS FREE, SET UP TO MOVE IF NOT
02500
02600 DBCHK:
02700 HRR D,$ACNO(PNT) ;GET CURRENT AC NUMBER
02800 TRNN FF,DBL ;WELL
02900 JRST IDXCHK ;NO DBL REQUESTED
03000
03100 SKIPGE ACKTAB+1(D) ;NEXT ONE NOT USABLE?
03200 JRST WIPCHK ; CANNOT BE USED, MAKE SEMANTIC CHANGES
03300
03400 HRRI D,1(D) ;STORE THE NEXT
03500 PUSHJ P,STORZ
03600 HRRI D,-1(D) ;RESTORE AC #
03700
03800
03900 IDXCHK: TRNE FF,INDX ;NEED INDX?
04000 TRNE D,-2 ; AND NOT IN ONE ALREADY?
04100 JRST SBSCHK ;OK, 'TWOULD SEEM
04200
04300
04400 Comment ⊗ If AC # is being changed (INAC and NEEDAC or SPAC and MOVE)
04500 clear right half of ACKTAB(AC), but first be sure nothing will be
04600 wiped out ⊗
04700
04800 WIPCHK: TLO A,1!2 ;HAVE TO MOVE IT
04900 WPCHK1: HRRZ TEMP,$ACNO(PNT) ;IT IS HERE CURRENTLY
05000 SKIPGE ACKTAB(TEMP) ;WAS THIS AC PROTECTED?
05100 ERR <DRYROT --AC CLOBBER>,1
05200 SETZM ACKTAB(TEMP) ;"STORR" (STORL DONE BEFORE)
05300 TDNN TBITS,[SBSCRP,,ITEM!ITMVAR!PROCED]
05400 TRNN TBITS,DBLPRC
05500 JRST WPCHK2 ;NOT VALUE LONG
05600 TLNE SBITS,PTRAC
05700 JRST WPCHK2 ;NEITHER IS THIS
05800 CAIN TEMP,RF-1
05900 ERR <DRYROT WIPCHK>,1
06000 CAIE TEMP,RF-1
06100 SETZM ACKTAB+1(TEMP) ;CLEAR 2ND AC OF LONG
06200 WPCHK2:
00100
00200 Comment ⊗ for STRING INDXED quantities (or non-STRING with ADDR)
00300 (guaranteed INAC by now) requiring a displacement,
00400 a "HRROI" FXTWO (or MOVEI)must be done --
00500 "HRRO" ("MOVE") with ADDR would yield a no-op
00600 ⊗
00700
00800 SBSCHK: TLNN SBITS,INDXED ;TEST THE CONDITONS
00900 JRST POSN ; NOT INDEXED
01000 HRRZ TEMP,$VAL(PNT) ;≠0 DISPLACEMENT?
01100 JUMPE TEMP,POSN ; NO DISPLACEMENT, NO PROBLEM
01200 ;; #OR# ! A STRING ITEMVAR IS NOT A STRING
01300 ;; #UE# ! NOR IS A STRING ARRAY
01400 TDNN TBITS,[XWD SBSCRP,ITMVAR!ITEM]; A STRING ITEM IS NOT A STRING
01500 TRNN TBITS,STRING ;INDXED STRING?
01600 JRST CHKNUM ; NO, CHECK GET!ADDR FOR NUMERIC ARRAY
01700 TRZ FF,ADDR ;JUST IN CASE
01800 TLO A,2!20 ;MOVE, HRROI, NO ADDR
01900 JRST POSN
02000
02100 CHKNUM: TRZE FF,ADDR ;WANT THE ADDRESS ALL TOGETHER?
02200 TLO A,100!2 ; YES, MOVE, MOVEI
02300 JRST POSN
02400
02500
02600 Comment ⊗ for strings, we must do a HRRO with ADDR
02700 turned ON (except for SBSCRP strings) ⊗
02800
02900 STCHK: TRNE FF,SPAC ;STORE AC IF SPAC
03000 PUSHJ P,STORZ
03100 TRNE TBITS,STRING ;STRING, NOT SBSCRP?
03200 ;;#VJ# ! JFR 10-17-75 A STRING PROCEDURE IS NOT A STRING, EITHER
03300 TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR!PROCED] ;NOT REALLY A STRING?
03400 JRST POSN
03500 TDO A,[XWD 2!10,ADDR] ;DO A "HRRO" ADDR
03600
03700 ; IF (POSIT(A) and NEGAT(SBITS)) or (NEGAT(A) and ¬ NEGAT(SBITS)) MUST
03800 ; DO SOMETHING ABOUT IT
03900
04000 POSN: TRNE FF,POSIT ;FIRST CONDITION
04100 TLNN SBITS,NEGAT
04200 JRST CHNGAT ; UNSATISFIED
04300 TLZ SBITS,NEGAT ;NO LONGER NEGAT
04400 TLO A,2!4 ;DO "MOVN"
04500 JRST CHKDX ;GO CHECK INDEXED
04600
04700 CHNGAT: TRNE FF,NEGAT ;SECOND CONDITION
04800 TLNE SBITS,NEGAT
04900 JRST CHKDX ; UNSATISFIED
05000 TLO SBITS,NEGAT ;NOW NEGAT
05100 TLO A,2!4 ;DO A "MOVN"
05200
05300 CHKDX: TLNN SBITS,INDXED ;IF INDXED, NOT STRING, NOT ADDR, BE
05400 JRST ADRCK
05500 ;; #RE# (1 OF 1) A STRING ITEMVAR ARRAY NOT A STRING ARRAY
05600 ;; #UE# ! (2 OF 3) STRING ARRAY INDXED TEMPS EXIST TOO
05700 TDNE TBITS,[XWD SBSCRP,ITMVAR!ITEM]
05800 JRST CHKDX2
05900 TRNE TBITS,STRING
06000 JRST ADRCK ;DOES NOT NEED A HRRO, HRROI
06100 CHKDX2:
06200 ;; # RE#
06300 ;;#TE# DAMNED CODE WAS PUTTING RESULT OF GET ADDR INAC
06400 TRNN FF,ADDR
06500 TLOA A,2 ; SURE SOME SORT OF MOVE GETS DONE
06600 TRO A,ADDR ;IN CASE OF INDXED THING, OK TO SAY "INAC"
06700 JRST ADRCKD ;(IF WAS STRING, MARKING INAC DOESN'T HURT)
06800 ADRCK: TRNE FF,ADDR ;NOW COPY THIS INTO A
06900 ;;#TE# ! USED TO BE A TRO A,ADDR
07000 TDO A,[400,,ADDR] ;LIKE ALL CPA'S.
07100 TRNE A,ADDR
07200 JRST GETWD ;WANT THE ADDRESS
07300 ADRCKD:
07400 TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR] ;THESE ARE BOGUS
07500 TRNN TBITS,DBLPRC
07600 JRST GETWD ;NOT DOUBLE
07700 TLO A,1000 ;USE DBL MOVES
07800 IORI FF,DBL ;AND DBL ACS
07900
00100
00200 GETWD: TRNN FF,NONSTD ;THE NON-STANDARD TYPE WILL
00300 ;**ALWAYS** GET AN AC.
00400 TLNE A,1 ;NEED AC?
00500 PUSHJ P,GETAC ; YES, GOT IT
00600 TLNN A,2 ;NEED TO MOVE?
00700 JRST [TLNN SBITS,INAC!PTRAC ;STRIVE TO PUT BITS BACK RIGHT
00800 JRST TMPRET
00900 TLNE SBITS,INDXED
01000 JRST IDXRET
01100 JRST GETRET] ;BEST AS POSSIBLE THE SAME AS ON ENTRY
01200 MOVE TEMP,A ;SAVE BITS SO YOU CAN TEST THEM
01300 PUSH P,A ;SAVE LH BITS
01400 HRLI A,(<MOVE>) ;ASSUME "MOVE"
01500 TLNE TEMP,1000 ;DOUBLE?
01600 HRLI A,(<DMOVE>)
01700 TLNE TEMP,4 ;MOVN?
01800 JRST [HRLI A,(<MOVN>) ; YES
01900 TLNE TEMP,1000
02000 HRLI A,(<DMOVN>) ;DOUBLE MOVN
02100 JRST .+1]
02200 TLNN TEMP,20!10 ;HRRO OR HRROI?
02300 JRST NOHRRO ;NO
02400 TRO A,FXTWO
02500 HRLI A,(<HRRO>)
02600 TLNE TEMP,20 ;ETC.
02700 HRLI A,(<HRROI>)
02800 NOHRRO:
02900 PUSH P,PNT
03000 TRNE TBITS,ITMVAR
03100 TLNN TBITS,MPBIND ;IF NOT ?ITEMVAR
03200 JRST NOTMPP ;CONTINUE
03300 TRZ A,ADDR
03400 ;; JRL FOLLOWING WAS MISTAKENLY A HRRI
03500 HRLI A,(<MOVEI @>)
03600 TRNE TEMP,ADDR ;ADDR REQUESTED
03700 ;; JRL FOLLOWING WAS MISTAKENLY A HRRI
03800 HRLI A,(<MOVE>)
03900 JRST EMTMOV ;EMIT THE MOVE
04000 NOTMPP: TLNE TEMP,100 ;FOR GET ADDR
04100 HRLI A,(<MOVEI>)
04200 TRO A,IMMOVE ;IF POSSIBLE
04300
04400 TRNE TBITS,ITEM ;OH MY GOSH AROODIES.
04500 JRST [TLNN TBITS,FORMAL!SBSCRP
04600 MOVE PNT,$VAL2(PNT) ; IT WILL BE AN INTEGER....
04700 JRST EMTMOV]
04800 REC <
04900 NORGC <
05000 TLNN TEMP,100 ;SPECIFIED IMMEDIATENESS
05100 TLNN TEMP,200 ;NO, THEN RECORD KLUGE IS A LIVE OPTION
05200 JRST EMTMOV ;NOT A RECORD KLUGERY INSTANCE
05300 RECKL2: HRLI A,(<SKIPE>) ;NEED TO BUMP REF CNT IF NOT NULL
05400 ;;BUG TRAP
05500 TRZE A,USCOND
05600 ERR <DRYROT: USCOND ON AT RECKL2>,1
05700 PUSHJ P,EMITER
05800 HRLOI A,(<AOS>) ;
05900 TLO A,(D) ;PUT AC NUMBER IN PLACE
06000 TLZ FF,RELOC ; NOT A RELOCATABLE -1 !
06100 PUSHJ P,CODOUT ; AOS -1(AC)
06200
06300 SKIPA ;SKIP OVER EMITER CALL AT EMTMOV
06400
06500 >;NORGC
06600 >;REC
06700 EMTMOV: PUSHJ P,EMITER
06800 POP P,PNT ;IN CASE OF ITEM.
06900
07000 POP P,A
07100 TLNE TBITS,MPBIND
07200 JRST [TLO SBITS,INAC
07300 TRNN A,ADDR ;ADDR?
07400 JRST ALLRET ;NO.
07500 ;; #PA#!(1OF 2) SAVE C ON CALL TO GET
07600 PUSH P,C
07700 HRLZI C,20 ;INDIRECT BIT
07800 EMIT <TLZN ,USADDR!NORLC>
07900 ;; #PA#!(2 OF 2) RESTORE C
08000 POP P,C
08100 EMIT <MOVEI ,0>
08200 TLZ SBITS,INAC
08300 JRST TMPRET] ;DON'T REMEMBER ADDR IS IN AC
08400
08500
08600 ;;#TE# DONT WANT TO ALWAYS REMEMBER THIS AC IN $ACNO
08700 GETRET: TLNN A,400 ;WAS IT REGULAR VBL, GET (ADDR)
08800 TRNE FF,NONSTD ;SPECIAL CASE OF PRESERVING INDXD TEMPS
08900 JRST [MOVE SBITS,$SBITS(PNT) ;RESTORE OLD MARKING.
09000 JRST TMPRT1] ;AND FINISH OUT.
09100 TLZ SBITS,PTRAC!INDXED!INAC ;START FROM SCRATCH
09200 TLNN A,20!40!100 ;INAC MARKING?
09300 JRST STDRET ; YES, DO IT
09400
09500 IDXRET: TLO SBITS,PTRAC!INDXED;KEEP INDXED BITS
09600 TLNN A,20!100 ;HRROI (MOVEI) THING?
09700 JRST ALLRET ; NO
09800 TLZ TBITS,OWN
09900 HLLZS $VAL(PNT) ; NO DISPL ANYMORE
10000 JRST ALLRET
10100
10200 STDRET: TDNN TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;NOT REALLY A STRING?
10300 TRNN TBITS,STRING ;KEEP BITS OFF IF STRING
10400 TLO SBITS,INAC
10500 ALLRET: HRRM PNT,ACKTAB(D) ;UPDATE SEMANTICS AND
10600 HRRM D,$ACNO(PNT) ; ACKTAB
10700 TLNN SBITS,PTRAC
10800 TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR] ;THESE ARE BOGUS
10900 JRST .+3
11000 TRNE TBITS,DBLPRC
11100 JRST [MOVEI TEMP,(D)
11200 CAIN TEMP,RF-1
11300 ERR <DRYROT ALLRET>,1
11400 CAIE TEMP,RF-1
11500 HRRM PNT,ACKTAB+1(D) ;SECOND AC OF DOUBLE
11600 JRST .+1]
11700
11800 TMPRET: MOVEM SBITS,$SBITS(PNT) ;IF ACCOP, THIS WILL BE NECESSARY
11900 TMPRT1: TRNN FF,MRK ;DOES HE WANT A MARK?
12000 JRST POST ;ALL DONE.
12100 PUSHJ P,REMOP ;AFTER ALL THAT?
12200 JRST MARK1 ;AH, WELL
12300
00100 COMMENT ⊗STACK -- Issue Instrs. to Stack Anything on Approp. Stack⊗
00200
00300 ↑↑STACK: TRNE FF,PREMASK ;ANY TO DO?
00400 PUSHJ P,PRE
00500 PUSHJ P,STACK1
00600 TRNN FF,MRK ;HAS HE ASKED FOR A MARK?
00700 JRST POST ;FINISH OUT.
00800 JRST MARK1 ;AND DO A MARK.
00900
01000
01100 STACK1: PUSH P,FF ;SAVE
01200 TRNN SBITS,DLFLDM ;DOES HE LIVE IN THE STACK?
01300 TLNE SBITS,INDXED
01400 PUSHJ P,ACCOP ;GET ACCESS.
01500 TDNE TBITS,[XWD SBSCRP,ITEM!ITMVAR] ;ALWAYS STACK ARRAYS ON P-STACK
01600 JRST ASTACK ; NO MATTER WHAT
01700 TRNN FF,ADDR ;MUST BE A CALL BY REF.
01800 TRNN TBITS,STRING ;STRING STACK?
01900 JRST ASTACK ;NO -- ARITHMETIC
02000 TLNE SBITS,STTEMP ;IF STTEMP and INUSE,
02100 ; ALREADY STACKED, DON'T DO AGAIN
02200 JRST MARTK ;JUST MARK AND QUIT
02300
02400
02500 MOVEI D,RSP ;TO AVOID CLOBBERING CORE.
02600 MOVE A,[PUSH RSP,STAK!BPWORD!LNWORD!ADOP!REM]
02700 TRNE FF,REM ; IF REM BIT IS ON IN FF THEN DON'T REMOP IN
02800 TRZ A,REM ; STROP1 SINCE POST WILL DO IT
02900 PUSHJ P,STROP1 ;THIS IS REALLY EASY. DO TWO PUSHES.
03000 ;; FOLLOWING WAS ERRONEOUSLY TO MARTK THUS REMOPING BLOCK TWICE
03100 ;; #ML ACTUALLY NEED TO LOAD SBITS AGAIN SHOULD BE MARTJ
03200 JRST MARTJ ;AND NOW MARK THINGS.
03300
03400
03500
03600 ASTACK: TLZN SBITS,NEGAT ;ARE THINGS CURRENTLY NEGATIVE?
03700 JRST OKPO ;NO
03800 TLNN SBITS,INAC!PTRAC
03900 ERR <DRYROT -- STACK NEGAT IN CORE?>,1
04000 HRL C,$ACNO(PNT)
04100 TRNE TBITS,DBLPRC
04200 JRST [HLR D,C ;SAME AC AS ADDR
04300 EMIT (DMOVN USADDR!NORLC) ;DMOVN AC,AC
04400 JRST ASTA.1]
04500 EMIT (MOVNS USADDR!NORLC!NOUSAC)
04600 ASTA.1: MOVEM SBITS,$SBITS(PNT);FOR THE EMITER.
04700 OKPO:
04800 REC <
04900 NORGC <
05000 TRNE TBITS,PNTVAR ;IS IT A PNTVAR (IE RECORD)
05100 TRNE TBITS,777777-(PNTVAR!GLOBL) ;
05200 JRST OKPO.1 ;NO
05300 TRNE FF,ADDR ;WANT ADDRESS?
05400 JRST OKPO.1 ;WON'T WORK ANYHOW
05500 PUSH P,FF ;
05600 GENMOV (GET,MRK) ;GET IT & MARK IT
05700 POP P,FF
05800 OKPO.1: ;
05900 >;NORGC
06000 >;REC
06100
06200 TLNE TBITS,MPBIND ;A ?ITEMVAR
06300 JRST [TRNE FF,ADDR ;ADDRESS REQUIRED?
06400 ERR <DRYROT -STACK ADDR ? ITEMVAR>
06500 TLNE SBITS,PTRAC!INAC
06600 JRST .+1
06700 PUSH P,D
06800 PUSHJ P,GETAC
06900 EMIT <MOVEI @,>
07000 PUSHJ P,MARKINT
07100 POP P,D
07200 JRST .+1]
07300 HRLZI A,(<PUSH RP,>)
07400 TRNE FF,ADDR ;COPY THIS BIT.
07500 TRO A,ADDR
07600 TRO A,NOUSAC ;WE HAVE SPECIFIED IT.
07700 PUSHJ P,EMITER ;PUT OUT THE PUSH.
07800 AOS ADEPTH ;SINCE WE USED THE PSTACK
07900 TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR] ;THESE ARE NOT DOUBLE
08000 JRST MARTK
08100 TRNE TBITS,DBLPRC
08200 TRNE FF,ADDR
08300 JRST MARTK ;ADDR OR NOT DOUBLE
08400 EMIT (<PUSH RP,NOUSAC!FXTWO>) ;SECOND WORD
08500 AOS ADEPTH
08600 MARTK: TRNN FF,REM ;IF REM BIT IS ON THEN DON'T DO REMOP SINCE POST
08700 ; WILL DO IT
08800 PUSHJ P,REMOP ;REMOVE THE THING YOU'RE STACKING
08900 MARTJ: MOVE SBITS,$SBITS(PNT);GET ITS BITS BACK FOR THE REST OF THIS
09000 MARTH: POP P,FF ;RESTORE
09100 POPJ P,
09200
00100 COMMENT ⊗MARK, MARKINT, MARKME -- Mark Semblk with Correct Temp Semantics
00200 This marks the AC (D) with a temp descriptor of type in SBITS, TBITS⊗
00300
00400 ↑↑MARK: TRNE FF,PREMASK ;
00500 PUSHJ P,[TRNE FF,657777
00600 ERR <MARK>,1
00700 JRST PRE]
00800 PUSHJ P,MARK1
00900 JRST POST ;ALL DONE.
01000
01100 MARK1: ANDI TBITS,MASK ;WANT ONLY THE TYPE BITS (NOT FORMAL,ETC.)
01200 ;;#NK# ! (1 OF 2) TEMPS SHOULD NOT HAVE DISPLAY LEVELS
01300 TDZ SBITS,[CORTMP!PTRAC!INDXED!FIXARR,,DLFLDM]
01400 ;;#HS# JRL AN ITEMVAR IS NOT ITS DATUM
01500 TRNE TBITS,ITMVAR!ITEM
01600 JRST .+3
01700 ;;#HS#
01800 TRNE TBITS,STRING ;IF STRING TYPE, THEN
01900 JRST STMARK
02000 TLO SBITS,INAC!ARTEMP!INUSE ;SINCE HE MAY NOT HAVE SET THEM.
02100 TLZ SBITS,STTEMP
02200 HRRE LPSA,ACKTAB(D) ;PICK UP TEMP DESCIRIPTOR
02300 JUMPLE LPSA,NOTEM ;IF NO TEMP OR REMOPPED TEMP
02400 MOVE USER,$SBITS(LPSA) ;GET SEMANTIC BITS
02500 TLNN USER,INUSE ;A TEMP?
02600 JRST REMM ;NO
02700 TLNN USER,CORTMP ;A CORE TEMP?
02800 JRST USOLD ;NO -- USE THE TEMP THAT IS THERE.
02900 TLNE USER,INAC ;IS IT STILL IN THE ACCUMULATOR?
03000 PUSHJ P,STORA ;YES --STORE IT.
03100
03200 SKIPA
03300 REMM: PUSHJ P,CLEARL ;DO THE REMOP
03400 NOTEM: PUSHJ P,GETTEM ;GET A NEW TEMPORARY
03500 USOLD: HRRM LPSA,ACKTAB(D) ;INSERT IN AC TABLE RIGHT HALF
03600 TLNN SBITS,PTRAC
03700 TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03800 JRST .+3
03900 TRNE TBITS,DBLPRC
04000 JRST [
04100 ;;#YX# 3! JFR 2-10-77 SPURIOUS MESSAGE FOR X←-((Y+Z)+Z);
04200 MOVE TEMP,ACKTAB(D)
04300 CAMN TEMP,ACKTAB+1(D)
04400 JRST .+1 ;ALREADY SAME, ASSUME RE-USE
04500 SKIPE ACKTAB+1(D)
04600 ERR <DRYROT MARK DOUBLE>,1
04700 MOVEI TEMP,(D)
04800 CAIE TEMP,RF-1 ;DO NOT CLOBBER RF!
04900 HRRM LPSA,ACKTAB+1(D);SECOND AC OF DOUBLE
05000 JRST .+1]
05100 HRRM D,$ACNO(LPSA) ;AND THE LOGICAL INVERSE.
05200 REC <
05300 TRNE TBITS,PNTVAR ;A RECORD TEMP
05400 TRNE TBITS,777777-(PNTVAR!GLOBL) ;
05500 JRST MARKT ;NOPE
05600 SKIPN TEMP,RCLASS ;BUG TRAP
05700 ERR <DRYROT: RCLASS=0 WHEN TRYING TO MARK RECORD TEMP>,1
05800 HRLM TEMP,$ACNO(LPSA) ;MARK IT
05900 SETZM RCLASS ;
06000 ;FALL INTO MARKT
06100 >;REC
06200 MARKT: HRRZM LPSA,PNT ;
06300 SETZM $VAL(PNT)
06400 MARTS: POPJ P,
06500 STMARK: TLO SBITS,STTEMP ;IN CASE IT SKIPS AND NOONE ELSE DID
06600 TLZ SBITS,ARTEMP
06700 HRRZ LPSA,PNT ;IN CASE STRTMP NOT CALLED
06800 TLNN SBITS,INUSE ;ALREADY HAS A TEMP?
06900 PUSHJ P,STRTMP ;GET A STRING TEMP.
07000 JRST MARKT
07100
07200 DSCR MARKINT, MARKME
07300 DES THESE ARE ROUTINES TO HELP YOU CALL "MARK"
07400 MARKINT -- ALWAYS MARKS A VANILLA INTEGER, RETURNS DESCR. IN PNT,SBITS,TBITS.
07500 MARKME -- YOU SPECIFY TBITS, SBITS=0 IS ASSUMED
07600 ⊗;
07700 ↑↑MARKINT: MOVEI TBITS,INTEGR ;MARK AN INTEGR,
07800 ↑↑MARKME: HRRI FF,0
07900 SETZ SBITS,
08000 JRST MARK1
08100
00100 COMMENT ⊗INCOR -- Issue Code to Clear this Entity from ACs⊗
00200
00300 DSCR INCOR
00400 DES makes sure that the entity mentioned in PNT,TBITS,SBITS is really
00500 in core. If not, the AC entry for that entity is cleared.
00600 The updated Semantics bits are returned in SBITS.
00700 ⊗;
00800
00900 ↑↑INCOR:
01000 TLZN SBITS,INAC!PTRAC ;GONE?
01100 POPJ P, ;ALL DONE!
01200 PUSH P,D ;SAVE THIS.
01300 HRRZ D,$ACNO(PNT) ;PICK UP RELEVANT AC.
01400 PUSHJ P,STORZ
01500 POP P,D
01600 JRST GETAD ;ALAS, SINCE STORZ WILL CHANGE THINGS.
01700
00100 COMMENT ⊗REMOPs, CLEARs -- Remove Temps, ACs, from Use⊗
00200
00300 DSCR REMOP,REMOPA,REMOPL,REMOP2
00400 DES These are the REMOP routines. They say, in effect, "I am
00500 finished with this argument. If it was a temp descriptor, then I
00600 am really finished, and the temp may be returned to the pool of
00700 such temps. If it was a simple variable or constant, etc. then no
00800 action is taken.
00900
01000 PAR The differences among the routines are only in the call form:
01100 REMOP -- PNT has pointer to entity.
01200 REMOPL -- LPSA has pointer to entity
01300 REMOPA -- D has AC number of entity.
01400 REMOP2 -- PNT2 has pointer to entity.
01500
01600 SID AC'S USED: LPSA,TEMP,USER
01700 ⊗;
01800
01900
02000 ↑REMOP2: MOVE LPSA,PNT2
02100 JRST REMOPL
02200 ↑REMOPA: SKIPA LPSA,ACKTAB(D) ;REMOP BY ACCUMULATOR NUMBER
02300 ↑REMOP: MOVE LPSA,PNT ;OH WELL.
02400 ↑REMOPL: TRNN LPSA,-1
02500 POPJ P, ;NONE THERE.
02600 MOVE TEMP,$SBITS(LPSA);THE STANDARD REMOP
02700 TLNN TEMP,STTEMP!ARTEMP!INUSE ;A REAL TEMP?
02800 JRST STCNST ;NO, CHECK IF A STRING CONSTANT
02900 DELAL:
03000 REC <
03100 NORGC <
03200 TLNN TEMP,INDXED
03300 JRST DRFDON ;DONT HAVE TO DEREFERENCE IT
03400 HRRZ USER,$VAL2(LPSA);WAS THIS GUY A RECORD SUBFIELD
03500 JUMPE USER,DRFDON ;IF NOT, THEN NOTHING TO WORRY ABOUT
03600
03700 SKIPN USER,%RVARB(LPSA);UNLINK SELF FROM SUBFIELD CHAIN
03800 ERR <DRYROT: REMOP OF SUBFIELD NOT ON SUBFIELD CHAIN>,1,SFULKD
03900 TRNE USER,-1 ;ASS END OF CHAIN ?
04000 HLLM USER,%RVARB(USER) ;NO, MAKE THE RIGHT GUY POINT AT MY LEFT
04100 MOVS USER,USER ;NOW LINK THE OTHER WAY
04200 HLRM USER,%RVARB(USER) ;MY LEFT POINTER NOW POINTS AT MY RIGHT
04300 SETZM %RVARB(LPSA) ;TIDY UP
04400 SFULKD: ;UNLINKING DONE NOW
04500
04600 HLLZS $VAL2(LPSA) ;MAKE SUBFIELD FLAG ZERO AGAIN
04700 HLRZ USER,%TLINK(LPSA); WAS THIS THING HANGING RECD REF
04800 CAIN USER,-1 ;IF SO,THIS IS -1
04900 JRST DREFIT ;IT WAS, MUST DE-REFERENCE THIS ONE
05000
05100 PUSH P,USER ;I AM A SUBFIELD OF A FIELD
05200 PUSHJ P,DRFDON ;KILL MYSELF OFF
05300 POP P,LPSA ;THEN REMOP THE FIELD I HUNG OFF OF
05400 JRST REMOPL ;
05500
05600 DREFIT:
05700 SETZM $VAL(LPSA) ;SO THAT THE DEREF WORKS
05800
05900 PUSH P,A ;SAVE SOME ACS
06000 PUSH P,C ;
06100 PUSH P,PNT
06200 PUSH P,TEMP
06300 PUSH P,LPSA
06400 ;;#RY# MUST DO RECUUO ON AC, NOT (AC)
06500 MOVE TEMP,$SBITS(LPSA)
06600 MOVEI C,ARTEMP+INAC+INUSE
06700 TLNE TEMP,CORTMP
06800 TRC C,INAC+CORTMP
06900 HRLM C,$SBITS(LPSA)
07000 ;;#RY#
07100 MOVNI C,1 ;TO DO DEREFERENCING BY 1, SET C TO -1
07200 MOVE PNT,LPSA ;THE THING TO DEREFERENCE
07300 PUSHJ P,RFCADJ ;ADJUST REFERENCE COUNT
07400 ;**** NOTE: MAY BE SAFER TO PUT THESE
07500 ; ONTO SOME "HANG LIST" UNTIL STATEMENT LEVEL
07600 ; THIS IS BETTER, THOUGH, IF NOTHING BAD HAPPENS
07700
07800 POP P,LPSA ;RECOVER THESE FROM EARLIER
07900 POP P,TEMP
08000 POP P,PNT ;
08100 POP P,C
08200 POP P,A
08300
08400 DRFDON:
08500
08600 ;; HERE CAN FALL INTO THE REST OF THE DELALL CODE. THIS WILL BE OK
08700 ;; SO LONG AS (1) DON'T SUFFER THE LOSSAGE I FEAR ABOUT ROUTINES ASSUMING
08800 ;; REMOP LEAVES PCNT THE SAME (ONE KLUGE WOULD BE TO SET A FLAG TO ALLOW
08900 ;; THE NEXT CALL TO ACCESS TO DO THE "RIGHT" THING, BUT UGH!
09000 ;; (2) THE CODE ABOVE ONLY GOBBLES THE SORT OF INDEXED TEMPS I EXPECT IT TO
09100 ;; IF NOT, MORE TESTING & MARKING IS REQUIRED
09200 >;NORGC
09300 RGC <
09400 ;;#WD# RHT 1-25-76 MAKE SURE THAT DEPENDENT TEMP TO STRING GOES, TOO.
09500 MOVE USER,$TBITS(LPSA) ;
09600 TLNE TEMP,INDXED ;INDEXED
09700 TRNN USER,STRING!DBLPRC ;STRING, TOO
09800 JRST RMP.00 ;NOPE
09900 TDNE USER,[XWD SBSCRP,PROCED!ITEM!ITMVAR] ;EXCEPT FOR THESE
10000 JRST RMP.00
10100 HRRZ USER,$VAL2(LPSA) ;IS IT SUBFIELD
10200 JUMPE USER,RMP.00 ;NO
10300 PUSH P,LPSA ;SAVE STATE
10400 PUSH P,TEMP ;
10500 HLRZ LPSA,$ACNO(LPSA) ;HAVE WE A DEPENDENT?
10600 SKIPE LPSA
10700 PUSHJ P,REMOPL ;YUP, FLUSH HIM, TOO
10800 POP P,TEMP
10900 POP P,LPSA
11000 JRST RMP.1 ;STRING SUBFIELD INDXED TEMPS
11100 ;DO NOT HAVE RECORDS AT ALL
11200 RMP.00:
11300 ;;#WD# ↑
11400 TLNN TEMP,CORTMP ;ONLY CORTMPS ARE SPECIAL
11500 JRST RMP.1 ;
11600 TLNN TEMP,INDXED ;INDXED CORTMP??
11700 JRST RMP.0 ;NOPE
11800 HRRZ USER,$VAL2(LPSA) ;RECORD SUBFIELD??
11900 JUMPE USER,RMP.1 ;NOPE
12000 MOVSI USER,CORTMP!INUSE!ARTEMP;MAKE INTO A RECORD CORTMP
12100 MOVEM USER,$SBITS(LPSA)
12200 MOVEI USER,PNTVAR
12300 MOVEM USER,$TBITS(LPSA) ;LIKE SO
12400 JRST RMP.RC ;PUT IT ONTO THE RIGHT RING
12500
12600 RMP.0:
12700 MOVE USER,$TBITS(LPSA) ;
12800 TRNE USER,PNTVAR ;WAS IT A RECORD CORTMP
12900 ;;#VQ# ! RECORD ARRAYS ARE ALSO OK
13000 TDNE USER,[XWD SBSCRP,ITEM!ITMVAR] ;THESE ARE OK
13100 JRST RMP.1 ;NOPE
13200 RMP.RC:
13300 ;;%##% BUG TRAP
13400 HRRZ USER,RCTEMP ;WAS THIS GUY ALREADY ON THE CHAIN
13500 JUMPE USER,RMP.0R ;NO CHAIN
13600 CAIN USER,(LPSA) ;WELL?
13700 ERR <DRYROT: RECORD CORTMP REMOP>,1
13800 HRRZ USER,(USER) ;CHAIN
13900 JUMPN USER,.-3
14000 RMP.0R: ;;%??% INSERTED HERE BY JFR 11-16-75
14100 ;;%##% ↑
14200 HRRZ USER,LPSA ;
14300 EXCH USER,RCTEMP ;
14400 HRRZM USER,%TLINK(LPSA) ;REMEMBER IT AS AN AVAILABLE
14500 JRST IACCHK ;RECORD TEMP
14600 ;(NOTICE THAT INUSE WAS LEFT ON)
14700 RMP.1:
14800 >;RGC
14900 >;REC
15000 MOVSI USER,INUSE!STTEMP!INAC!PTRAC!NEGAT!FIXARR ;TURN THESE OFF
15100 ANDCAM USER,$SBITS(LPSA) ;IN MEMORY.
15200 IACCHK: HRRZ USER,$ACNO(LPSA) ;GET THE AC IT WAS IN
15300 TLNN TEMP,INAC!PTRAC ;WAS IT IN AN AC?
15400 JRST CTCHK ;NO -- ALL DONE.
15500 SKIPGE ACKTAB(USER) ;YES --TURN IT OFF.
15600 ERR <DRYROT -- REMOP>,1
15700 SETZM ACKTAB(USER)
15800 TLNN TEMP,PTRAC
15900 TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
16000 JRST .+3
16100 TRNE TBITS,DBLPRC
16200 JRST [CAIN USER,RF-1
16300 ERR <DRYROT IACCHK>,1
16400 CAIE USER,RF-1
16500 SETZM ACKTAB+1(USER)
16600 JRST .+1]
16700 CTCHK: TLNE TEMP,INUSE ;If this was still an alive temp, and
16800 TLNE TEMP,CORTMP ; was not a CORTMP, thus contains no fixups
16900 POPJ P, ; or anything, we can release it to free
17000 PUSH P,LPSA ; storage. Otherwise, leave it on the TTEMP
17100 PUSHJ P,BLKFRE ; list (where it MUST be), and forget it.
17200 POPJ P,
17300
17400
17500 STCNST: MOVE TEMP,$TBITS(LPSA) ;
17600 TLNE TEMP,CNST ;
17700 TRNN TEMP,STRING ;
17800 POPJ P, ; RETURN IF NOT A STRING CONSTANT
17900 MOVE TEMP,$PNAME(LPSA) ; CHECK IF TRYING TO REMOP NULL STRING WHICH IS
18000 TRNN TEMP,-1 ; ONLY STRINS'ED ONCE
18100 POPJ P, ; YES, DON'T REMOP
18200 SOSLE TEMP,$VAL2(LPSA) ; DECREMENT REFERENCE COUNT AND GET OUT IF NOT
18300 POPJ P, ; ZERO
18400 JUMPE TEMP,.+2 ; ZERO COUNT?
18500 ERR <DRYROT REMOP:STCNST> ;
18600 SKIPN $VAL(LPSA) ; USED IN PRELOAD?
18700 SKIPE $ADR(LPSA) ; USED IN FIXUP?
18800 POPJ P, ; YES, RETURN
18900 PUSHJ P,URGCST ; REMOVE FROM STRING CONSTANT RING
19000 PUSHJ P,URGSTR ; REMOVE FROM STRING RING
19100 PUSH P,PNAME ; SAVE PNAME AND PNAME+1 (OK ON P STACK SINCE NO
19200 PUSH P,PNAME+1 ; GARBAGE COLLECTION CAN HAPPEN)
19300 HRROI TEMP,$PNAME+1(LPSA) ; GET STRING DESCRIPTOR FOR HASH LOOKUP SO THE
19400 POP TEMP,PNAME+1 ; STRING CAN BE REMOVED FROM THE HASHED SYMBOL
19500 POP TEMP,PNAME ; TABLE
19600 PUSH P,TBITS ; SAVE AC'S WHICH SHASH WILL DESTROY
19700 PUSH P,A ;
19800 PUSH P,B ;
19900 PUSH P,C ;
20000 PUSH P,D ;
20100 PUSH P,PNT ;
20200 PUSH P,LPSA ;
20300 MOVE LPSA,STRCON ; USE STRING HASH TABLE
20400 PUSHJ P,SHASH ;
20500 MOVE B,HPNT ; INSTRUCTION TO LOAD FIRST IN CONFLICT LIST
20600 XCT B ; FIRST IN CONFLICT LIST INTO LPSA
20700 HRRZ PNT,(P) ; THE ONE WE ARE LOOKING FOR
20800 MOVEI A,LPSA ;
20900 SCOMLP: HRRZ TEMP,(A) ; CANDIDATE?
21000 JUMPE TEMP,ERRSTC ; NOT THERE - ERROR
21100 CAMN TEMP,PNT ;
21200 JRST SFNDIT ;
21300 MOVE A,TEMP ; CHAIN DOWN CONFLICT LIST
21400 JRST SCOMLP ;
21500 SFNDIT: HRRZ TEMP,(TEMP) ; NEXT IN LIST
21600 HRRM TEMP,(A) ; CHAIN AROUND DELETED ELEMENT
21700 TLO B,2000 ; CHANGE FROM LOAD TO STORE
21800 XCT B ;
21900 FREBLK (PNT) ;
22000 POP P,LPSA ; RESTORE AC'S
22100 POP P,PNT ;
22200 POP P,D ;
22300 POP P,C ;
22400 POP P,B ;
22500 POP P,A ;
22600 POP P,TBITS ;
22700 POP P,PNAME+1 ;
22800 POP P,PNAME ;
22900 POPJ P, ;
23000 ERRSTC: ERR <DRYROT AT REMOP>,1 ;
23100
00100 DSCR CLEAR,CLEARL,CLEARA
00200 DES These are routines to clear an entry in the AC table (ACKTAB)
00300 That is, all memory of what is in the AC is lost. The difference
00400 among the routines is the call form:
00500
00600 PAR CLEAR -- PNT has pointer to entity to be "cleared"
00700 If it turns out not to be in an AC, no action is taken.
00800 CLEARL -- LPSA has pointer; same deal.
00900 CLEARA -- D has AC number to be cleared.
01000
01100 SID AC'S USED: LPSA,TEMP
01200 ⊗;
01300
01400 ↑CLEAR: MOVEI LPSA,(PNT) ;CLEAR OUT AN AC TABLE ENTRY.
01500 ↑CLEARL: MOVE TEMP,$SBITS(LPSA) ;SEE IF IT IS IN AN AC.
01600 TLNN TEMP,INAC!PTRAC ;IF NOT -- ALL DONE.
01700 POPJ P, ;DONE.
01800 MOVE TEMP,$ACNO(LPSA) ;AC IT IS IN.
01900 ;;#YJ# 2! JFR 1-13-77 QUIT IF NOTHING THERE
02000 SKIPN ACKTAB(TEMP)
02100 JRST CLR1
02200 SETZM ACKTAB(TEMP) ;AND ZERO THE ENTRY.
02300 MOVE TEMP,$SBITS(LPSA)
02400 TLNE TEMP,PTRAC
02500 JRST CLR1 ;POINTERS ARE NOT LONG
02600 MOVE TEMP,$TBITS(LPSA)
02700 TDNN TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR] ;LEAP IS NOT LONG
02800 TRNN TEMP,DBLPRC ;LONG?
02900 JRST CLR1 ;NO
03000 HRRZ TEMP,$ACNO(LPSA);YES, REFETCH AC
03100 JRST CLR2
03200
03300 ↑CLEARA:
03400 SKIPN LPSA,ACKTAB(D)
03500 POPJ P, ;NOTHING THERE
03600 CAMN LPSA,ACKTAB-1(D) ;POSSIBLE DBLPRC SCREWUP?
03700 SOJA D,[PUSHJ P,CLEARA ;YES, CLEAR FIRST AC INSTEAD
03800 AOJA D,CPOPJ] ;RESTORE D
03900 SETZM ACKTAB(D) ;ZERO AC TABLE ENTRY
04000 MOVE TEMP,$SBITS(LPSA)
04100 TLNE TEMP,PTRAC
04200 JRST CLR1 ;POINTERS ARE NOT LONG
04300 MOVE TEMP,$TBITS(LPSA)
04400 TDNE TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR]
04500 JRST CLR1
04600 TRNE TEMP,DBLPRC ;DOUBLE?
04700 JRST [MOVEI TEMP,(D)
04800 CLR2: HLL LPSA,ACKTAB+1(TEMP) ;MAKE COMPARISON ON RIGHT HALF ONLY
04900 CAIE TEMP,RF-1 ;MAKE THIS IRON-CLAD
05000 CAME LPSA,ACKTAB+1(TEMP);NEXT AC SHOULD BE SAME
05100 ERR <DRYROT CLEAR DOUBLE>,1
05200 CAIE TEMP,RF-1
05300 SETZM ACKTAB+1(TEMP) ;CLEAR SECOND AC
05400 JRST .+1]
05500 CLR1: MOVSI TEMP,INAC!PTRAC!NEGAT
05600 TRNE LPSA,-1 ;ANYTHING THERE? (DCS -- 8/16/70)
05700 ANDCAM TEMP,$SBITS(LPSA) ;TURN THESE OFF IN MEMORY.
05800 POPJ P,
05900
00100 COMMENT ⊗STROP -- Bit-Driven String Operation Code Generator⊗
00200
00300 DSCR STROP
00400 DES This routine is willing to do lots of twiddling on strings.
00500 It knows about reference strings, etc.
00600 PAR A is an instruction for the EMITTER, with some bits in
00700 it to say what things should be done with this instruction.
00800 Bits in A: bpword -- issue the instruction for
00900 the byte pointer word.
01000 lnword -- or for the length word.
01100 bpfirst -- issue the byte pointer inst. first.
01200 adop -- this is an instruction which adds to stack.
01300 sbop -- this is an instruction which subs from stack.
01400 undo -- so a SUB SP,X22 at end.
01500 rem -- do a remop when done.
01600
01700 stak -- used internally.
01800 bpinc -- byte pointer instruction is in c(rh)
01900
02000 PNT,TBITS,SBITS -- semantics of string.
02100
02200 D -- accumulator to use for ac field of op.
02300 Thus, it must be RSP if that stack is to be used.
02400 ⊗;
02500
02600
02700 ↑STROP: CAIN D,RSP ;IF THE STACK,
02800 TRO A,STAK ;THEN MARK AS SUCH.
02900 DPB D,[POINT 4,A,12] ;SAVE IN AC FIELD OF INSTRUCTION.
03000 PUSHJ P,ACCOP ;AND GET ACCESS TO THE ROUTINE.
03100 ;THIS UPDATES SBITS IN CORE.
03200 STROP1: PUSH P,ACKTAB(D) ;PROTECT.
03300 SETOM ACKTAB(D)
03400 PUSH P,D ;SAVE AC.
03500 TLNN TBITS,REFRNC ;THE HARD CASE.
03600 JRST OPPP1 ;
03700 PUSH P,A ;SINCE GETOPE DOES NOT PRESEVE.
03800 HRRI FF,ADDR!INDX
03900 PUSHJ P,GETOPE ;GET THE ADDRESS OF THE BP WORD IN AN AC.
04000 ;THIS UPDATES SBITS IN CORE.
04100 SETZM ACKTAB(D) ;WE DO NOT WANT TO SEE THIS AGAIN.
04200 HRLZS D ;READY FOR INDEXING.
04300 POP P,A
04400 OPPP1: TLNE SBITS,STTEMP ;IF STACKED, THEN NEED
04500 HRLI D,RSP ;THE STACK
04600 HRRI FF,(A) ;SAVE BITS.
04700 TRNE FF,BPFIRST ;IF BYTE POINTER WORD FIRST, DO IT
04800 PUSHJ P,BP
04900 PUSHJ P,LN ;NOW THE LENGTH
05000 TRNN FF,BPFIRST
05100 PUSHJ P,BP
05200
05300 TRNE FF,UNDO
05400 TLNN SBITS,STTEMP ;IF UNDO AND A STACKED STRING.
05500 JRST OP2 ;
05600 PUSHJ P,SUBIT
05700 OP2: POP P,D ;RESTORE.
05800 POP P,ACKTAB(D)
05900 TRNE FF,REM ;IF REMOP ASKED FOR.
06000 JRST REMOP
06100 POPJ P, ;ALL DONE.
06200
06300
06400 DSCR SUBIT
06500 DES Emits a SUB SP,[XWD 2,2], and subtracts two from SDEPTH.
06600 ⊗;
06700 ↑SUBIT:
06800 ;;%DN% JFR 7-2-76
06900 ;; PUSH P,A
07000 MOVNI A,2
07100 ADDM A,SDEPTH
07200 HRLI C,-2
07300 JRST ESPADJ
07400 ;; MOVE A,X22 ;SUBTRACT TWO FROM THE STACK.
07500 ;; PUSH P,PNT
07600 ;; PUSHJ P,CREINT
07700 ;; EMIT (<SUB RSP,NOUSAC>) ;THEN ISSUE THE SUBS.
07800 ;; PUSHJ P,REMOP ;JUST IN CASE
07900 ;; POP P,PNT
08000 ;; MOVNI A,2
08100 ;; ADDM A,SDEPTH ;UPDATE COUNT.
08200 ;; POP P,A
08300 ;; JRST GETAD ;RESTORE TBITS,SBITS.
08400 ;;%DN% ↑
08500
08600 BP: TRNN FF,BPWORD ;ONLY IF ASKED FOR.
08700 POPJ P,
08800 PUSH P,A ;SAVE
08900 TRNE FF,BPINC ;IF ANOTHER INSTRUCTION AROUND.
09000 DPB C,[POINT 9,A,8] ;IN INSTRUCTION PARTS.
09100 HRRI A,NOUSAC!FXTWO ;TENTATIVE BITS TO EMITER.
09200 TLNN SBITS,STTEMP ;IF ON STACK OR
09300 TLNE TBITS,REFRNC ;BUT IF THIS CASE, THEN
09400 TRC A,FXTWO!NORLC!USX!USADDR
09500 HRLI C,0 ;WITH NO DISCPLACEMENT.
09600 PUSHJ P,EMITER
09700 POP P,A
09800 JRST FINBP
09900
10000 LN: TRNN FF,LNWORD ;ONLY IF ASKED
10100 POPJ P,
10200 HRRI A,NOUSAC
10300 TLNN SBITS,STTEMP ;IF TEMP OR
10400 TLNE TBITS,REFRNC ;REFERENCE, THEN MUST USE
10500 TRO A,NORLC!USX!USADDR ;INDEXING ETC.
10600 HRLI C,-1 ;ANO THIS TIME A DISPLACEMENT.
10700 PUSHJ P,EMITER
10800
10900 FINBP: TRNE FF,ADOP!SBOP ;PREPARE TO ADJUST STACK.
11000 TRNN FF,STAK ;ONLY IF ON STACK.
11100 POPJ P, ;NONE.
11200 TRNE FF,ADOP
11300 AOSA SDEPTH
11400 SOS SDEPTH ;OUR BOOKKEEPING DONE,
11500 POPJ P, ;WE DEPART.
11600
11700
11800 ;;%DN% JFR 7-4-76
11900 DSCR EADJSP, EPADJ, ESPADJ
12000 DES Emits instruction to alter stack depth
12100 PAR LH(C) proper constant for ADJSP
12200 RH(D) stack ac for EADJSP.
12300 RES ADJSP emitted if allowed, else proper ADD or SUB
12400 SID A, TEMP clobbered. PNT,TBITS,SBITS saved
12500 ⊗;
12600
12700 ↑EADJSP:MOVEI TEMP,(D) ;AC
12800 CAIE TEMP,RP ;FIGURE OUT WHICH STACK
12900 ↑ESPADJ:SKIPA A,[ADJSP RSP,NOUSAC!USADDR!NORLC]
13000 ↑EPADJ: MOVE A,[ADJSP RP,NOUSAC!USADDR!NORLC]
13100 MOVE TEMP,ASWITCH
13200 TRNE TEMP,AADJSP
13300 JRST EMITER ;EASY WAY
13400 PUSH P,PNT ;SAVE THIS GUY
13500 PUSH P,TBITS
13600 PUSH P,SBITS
13700 JUMPL C,.+2 ;FIGURE OUT ADD OR SUB
13800 TLCA A,(<ADJSP>≠<ADD>)
13900 TLC A,(<ADJSP>≠<SUB>)
14000 TRZ A,USADDR!NORLC
14100 PUSH P,A ;SAVE INSTR FOR LATER
14200 HLRE A,C ;COMPUTE CONSTANT
14300 MOVM A,A
14400 HRLI A,(A)
14500 PUSHJ P,CREINT ;MAKE AN XWD
14600 POP P,A ;GET INSTR BACK
14700 PUSHJ P,EMITER ;PUT OUT INSTR, PNT POINTS TO XWD
14800 POP P,SBITS
14900 POP P,TBITS
15000 POP P,PNT ;GET IT BACK
15100 POPJ P,
15200 ;;%DN% ↑
00100 COMMENT ⊗GETTEM, etc. -- Temp Semblk Allocators⊗
00200
00300 DSCR GETTEM,GETCRTMP,STRTMP
00400 DES Routines for getting temp descriptor Semblks. The list of
00500 free temps is searched for an appropriately free one. If found,
00600 a masked form of TBITS, and a masked form of SBITS are stored
00700 in the Semblk for this temp. A pointer to it is returned in LPSA
00800 INCL more descriptions about temps, their numbers, how they're
00900 moved, kept track of, deleted, depend on procedures, etc.
01000
01100 GETTEM -- get a non-core temp
01200 STRTMP -- get a String temp (i.e. turn on the STTEMP bit in SBITS)
01300 GETCRTMP -- get a core temp.
01400
01500 SID AC'S USED: USER,LPSA,TEMP
01600 ⊗;
01700
01800 STRTMP: TLOA SBITS,INUSE!STTEMP
01900 ↑GETTEM: TLO SBITS,INUSE!ARTEMP ;TURN ON TEMP BITS.
02000 ;;#NK# ! (2 OF 2) TEMPS SHOULD NOT HAVE DISPLAYS LEVELS
02100 TDZ SBITS,[CORTMP,,DLFLDM]
02200 GETBLK ;GET A NEW BLOCK
02300 GTT1: MOVEM SBITS,$SBITS(LPSA)
02400 ANDI TBITS,MASK
02500 MOVEM TBITS,$TBITS(LPSA) ;GOOD BITS IN MEMORY
02600 POPJ P, ;NOTHING ELSE TO DO
02700
02800 ↑GETCRTMP: ;GET A CORE TEMP
02900 SKIPA LPSA,TTEMP
03000 STRG: LEFT ,%RVARB,NOFF
03100 MOVE TEMP,$SBITS(LPSA)
03200 TLNE SBITS,CORTMP
03300 TLOE TEMP,INUSE
03400 JRST STRG
03500 TLNE SBITS,PTRAC
03600 JRST DDRET ;POINTERS ARE NOT LONG
03700 TDNN TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
03800 TRNN TBITS,DBLPRC
03900 JRST DDRET ;NOT DBL
04000 MOVE TEMP,$TBITS(LPSA)
04100 TDNN TEMP,[SBSCRP,,PROCED!ITEM!ITMVAR]
04200 TRNN TEMP,DBLPRC
04300 JRST STRG ;NEED DBL TEMP FOR DBL QTY
04400 DDRET: MOVSI SBITS,INUSE!CORTMP!ARTEMP
04500 JRST GTT1 ;FINISH OUT AS ABOVE.
04600
04700 NOFF: PUSHJ P,GETTEM
04800 AOS TEMP,TEMPNO ;INCREMENT TEMP ID NO
04900 MOVEM TEMP,$PNAME(LPSA) ;STORE IN $PNAME FOR ADCON AND SCOUT
05000 SETZM $ADR(LPSA) ;AND ZERO THE FIXUP.......
05100 PUSHJ P,RNGTMP
05200 JRST DDRET
05300
05400 RGC <
05500 ↑GETRCT:SKIPE SIMPSW ;SIMPLE PROCEDURE??
05600 ERR <ATTEMPT TO CREATE A RECORD TEMP INSIDE A SIMPLE PROCEDURE>,1
05700 HRRZ LPSA,RCTEMP ;GET NEXT OFF RECORD TEMP CHAIN
05800 JUMPE LPSA,GRCT.1 ;NONE THERE
05900 HRRZ TEMP,%TLINK(LPSA);
06000 MOVEM TEMP,RCTEMP
06100 POPJ P,
06200 GRCT.1: GETBLK
06300 PUSHJ P,RNGTMP
06400 AOS TEMP,TEMPNO
06500 MOVEM TEMP,$PNAME(LPSA)
06600 MOVSI TEMP,ARTEMP!INUSE!CORTMP
06700 MOVEM TEMP,$SBITS(LPSA)
06800 MOVEI TEMP,PNTVAR
06900 MOVEM TEMP,$TBITS(LPSA)
07000 POPJ P,
07100 >;RGC
07200
07300
00100 COMMENT ⊗GETAC, GETAN0 -- AC Allocators⊗
00200
00300 DSCR GETAC,GETAN0
00400 DES These are the "get a free AC routines".
00500 PAR FF(rh) -- two modifier bits:
00600 DBL -- get a double AC (i.e. next one free too)
00700 INDX -- get an indexable AC (not 0 or 1 -- 1 is avoided since
00800 Procedures tend to return values in 1).
00900 RES in D is returned the free (first free) AC number
01000 Note that no ACKTAB marking has been done yet, so the AC
01100 need not be used.
01200
01300 GETAN0: same as GETAC, but INDX is autimatically turned on.
01400
01500 AC'S USED: TEMP,LPSA
01600 ⊗;
01700
01800 ↑GETAN0: TRO FF,INDX ;HERE IF YOU DON'T WANT TO SET THE BIT
01900 ↑GETAC:
02000 HRR D,ACKPNT ;LAST AC USED
02100 SETOM ACKPNT ;CLEAR IT
02200 SETZM POSSIB ;MASK OF POSSIBILITIES
02300 MOVNI TEMP,20 ;NUMBER OF AC'S TO SEARCH
02400
02500 ;;#HF# 5-13-72 DCS RETURN OLDEST AVAILABLE AC IF NONE FREE, FIX DBL
02600 GET1: AOJG TEMP,GET7 ;For each AC, starting with the one
02700 ADDI D,1 ; after the last allocated, and wrapping
02800 TRZ D,777760 ; around to 0 (2 if GETAN0), if the AC
02900 TRNE FF,INDX ; is not protected (ACKTAB(AC)<0),
03000 TRNE D,-2 ; record the (oldest) first one seen in
03100 SKIPGE LPSA,ACKTAB(D) ; ACKPNT -- if the entry is free (0),
03200 JRST GET1 ; try to terminate. Otherwise, continue
03300 SKIPGE ACKPNT ; looking for a free one.
03400 HRRZM D,ACKPNT
03500 TRNN LPSA,-1
03600 JRST GET4
03700 JRST GET1
03800
03900 ; ONE FREE ONE EXISTS -- JUST RECORD IF DBL (NEED TWO)
04000
04100 GET4: TRNN FF,DBL ;If only one AC is needed, it's number
04200 JRST DSTORZ ; is in D.
04300
04400 GET3: MOVEI LPSA,1 ;Otherwise, record its number in the
04500 LSH LPSA,(D) ; bit array POSSIB. This is not the
04600 IORM LPSA,POSSIB ; most efficient method, but it allows
04700 JRST GET1 ; the fun below.
04800
04900 ; LIST EXHAUSTED -- TAKE WHAT WE COULD GET
05000
05100 GET7: TRNE FF,DBL ;If two were needed, we must work
05200 JRST GET9 ; harder.
05300
05400 ; TAKE A DISPLAY TEMP FIRST
05500
05600 SKIPE DISLST ;ONLY ANY GOOD IF HAVE SOME
05700 SKIPG LPSA,CDLEV ;CURRENT DISPLAY LEV
05800 JRST GET7.1
05900 HRRI D,1 ; COULD NEVER BE ZERO OR 1
06000 GET7.2: SKIPE DISTAB(D)
06100 JRST GET7.3 ;THIS THING HAS AN AC
06200 AOS D ;TRY THE NEXT ONE UP
06300 SOJG LPSA,GET7.2
06400 ERR <DRYROT AT GETAC> ;YOU REALLY BLEW IT, SAM
06500 GET7.3: MOVE LPSA,DISTAB(D) ;PICK IT UP
06600 TLNE LPSA,-1 ;USE STRING DISPLY IF WE CAN
06700 MOVSS LPSA ;US STRING -HURRAH
06800 CAIN LPSA,RF ;
06900 JRST GET7.1 ;IF RF, THEN NO GO
07000 HRR D,LPSA ;WE CAN GRAB THIS ONE
07100 SKIPG ACKTAB(D)
07200 ERR <GETAC GRABBED SAFE AC -- DRYROT AND WORMS>
07300 JRST DSTORZ ;RECORD IT, CLEAR IT OUT
07400 GET7.1:
07500
07600 ; NO DISPLAY TEMP, CLEAR SOMETHING ELSE OUT AND USE IT.
07700
07800 HRR D,ACKPNT ;Use the first one recorded, which
07900 JRST STORZ ; is also the oldest found
08000
08100 ; WE NEED TWO -- TRY FOR TWO UNUSED IN A ROW
08200
08300 GET9: MOVE LPSA,POSSIB ;If any two in a row were free,
08400 LSH LPSA,1 ; the AND of the bits and 2*bits
08500 AND LPSA,POSSIB ; will yield a bit for each pair.
08600 JUMPE LPSA,G10 ;No bits implies no pairs.
08700 FSC LPSA,231 ;The FSC shifts the first match
08800 LDB LPSA,[POINT 4,LPSA,8] ; to a normalized position, and
08900 MOVEM LPSA,ACKPNT ; records its index in the exponent
09000 HRR D,LPSA ; field.
09100 POPJ P,
09200
09300
09400 G10: HRRI D,21 ;As a last resort, take the first
09500 G11: SUBI D,2 ; two unprotected ACs available.
09600 TRNE D,777000 ;If none are found, complain bitterly.
09700 ERR <DRYROT AT DBL GETAC> ;This could be improved by
09800 SKIPL LPSA,ACKTAB(D) ; looking for the oldest pair, and/or
09900 SKIPGE ACKTAB-1(D) ; a pair with one free AC, but at
10000 JRST G11 ; this point, we're sort of beyond
10100 JUMPE LPSA,.+2 ; caring.
10200 PUSHJ P,STORZ ;Store the second, if it needs it.
10300 SUBI D,1 ;This is the result.
10400
10500 DSTORZ: HRRZM D,ACKPNT ;Allocating this one. Now go make
10600 JRST STORZ ; sure it's ready for new action.
10700 ;;#HF#
10800
00100 COMMENT ⊗AC Store routines -- BOLSTO, FORSTO, STORIX, GOSTO, STORZ⊗
00200
00300 DSCR BOLSTO
00400 DES Special Boolean store. It does not remove from ACs any
00500 of the arguments to the Boolean compare.
00600 PAR PNT and PNT2 must point to Semantics of the two arguments.
00700 RES All other ACs are stored. The Semantics of the parameters
00800 are not necessarily guaranteed over the call, since either
00900 may have been marked for storing.
01000 SEE STORZ, which it calls for each AC cleared
01100 ⊗;
01200
01300
01400 ↑BOLSTO: PUSH P,[PUSHJ P,[
01500 HRRZ TEMP,LPSA
01600 CAIE TEMP,(PNT2)
01700 CAIN TEMP,(PNT)
01800 POPJ P,
01900 JRST STORZ]] ;DO TURN OFF ACSAME FOR THESE GUYS.
02000 ; THIS STORZ IS NEEDED BECAUSE A PARTICULAR BOOLEAN MAY LOOK LIKE:
02100 ; MOVE 4,I
02200 ; SKIPN J
02300 ; JRST FOO1
02400 ; MOVE 4,J+K
02500 ; SKIPE GH
02600 ; JRST SHIT
02700 ;FOO1: ..... HERE THE COMPILER THINKS J+K IS IN 4, WHERE I MIGHT BE!!!
02800 ;
02900
03000 JRST GG0
03100
03200 DSCR FORSTO
03300 DES Special AC dumper for FOR Loops. This protects the index
03400 AC from being cleared. Other variables are not cleared, just
03500 stored if temps.
03600 PAR PNT and PNT2 should point to anything to be preserved
03700 over this operation (e.g. FOR I← <EXP> STEP .... want to preserve
03800 I and the Semantics of <EXP> from storing before the test.
03900 SEE STORA, which it calls for each AC stored.
04000 ⊗;
04100
04200 ↑FORSTO: PUSH P,[PUSHJ P,[HRRZ TEMP,ACKTAB(D) ;FOR FOR LOOPS.
04300 CAIE TEMP,(PNT)
04400 CAIN TEMP,(PNT2)
04500 POPJ P,
04600 ;DCS -- 8/16/70
04700 PUSHJ P,STORA ;STORE IT FOR SURE
04800 JUMPE LPSA,NSBSC ;NOTHING TO CLEAR
04900 ;;#MU# RHT 6-25-73 I THINK THE FOLLOWING DISTINCTION IS POINTLESS
05000 ; MOVE TEMP,$TBITS(LPSA) ;IF AN INAC ARRAY,
05100 ; TLNE TEMP,SBSCRP ;CLEAR IT, BECAUSE WILL
05200 ;;#MU#
05300 JRST CLEARL ;STILL BE ASSUMED INAC AT
05400 NSBSC: POPJ P, ; LOOP TOP OTHERWISE
05500 ]] ;DCS -- 8/16/70
05600
05700 JRST GG0
05800
05900
06000 DSCR STORIX
06100 DES "Store" all INTERNALs and EXTERNALs, i.e. forget that
06200 they are in ACs.
06300 ⊗;
06400 ↑STORIX: PUSH P, [PUSHJ P,[
06500 HRRZ LPSA,ACKTAB(D)
06600 JUMPE LPSA,CPOPJ ;NOTHING THERE.
06700 MOVE LPSA,$TBITS(LPSA)
06800 TLNE LPSA,INTRNL!EXTRNL
06900 JRST CLEARA
07000 POPJ P,]]
07100 JRST GG0
07200
07300
07400 DSCR ALLSTO
07500 DES Dump all ACs in the most permanent of ways. Do not
07600 retain any marking of the AC's at all.
07700
07800 SEE STORZ, which it calls for each AC gronked.
07900 ⊗;
08000
08100 ↑ALLSTO:OPTSYM %ALSTO
08200 PUSH P,[PUSHJ P,STORZ] ;TO CLEAR INAC" BITS.
08300 SKIPA
08400
08500 DSCR GOSTO
08600 DES Store any AC's marked with temps (as opposed to variables).
08700 Leave the AC markings as they are.
08800 Storing in forward direction makes life easier for LONG (double) things.
08900 ⊗;
09000
09100 ↑GOSTO: PUSH P,[PUSHJ P,STORA]
09200 GG0: PUSH P,D
09300 MOVSI D,-20 ;D, WHO WILL HAVE A COUNT
09400 SKIPLE LPSA,ACKTAB(D) ;DO WE HAVE A STORE TO DO?
09500 XCT -1(P) ;EXECUTE STORING ROUTINE.
09600 AOBJN D,.-2
09700
09800 ALLD: POP P,D
09900 POP P,(P) ;THROW AWAY
10000 POPJ P, ;AND RETURN
10100
10200
10300 DSCR STORZ
10400 DES "Store" this AC and wipe out the ACKTAB entry -- clear
10500 INAC-type SBITS in the Semantics which were there.
10600 PAR AC # in D
10700 SEE STORA,CLEARA routines, which it calls
10800 ⊗;
10900
11000 ↑STORZ: PUSHJ P,STORA
11100 JRST CLEARA
11200
00100 COMMENT ⊗ STORA -- main AC-storing subr. -- called by above⊗
00200
00300 DSCR STORA
00400 DES Stores temp results that are in a specified AC into
00500 a core temp. If a temp exists in that AC, an appropriate core
00600 temp is found, and the Stoe is EMITted.
00700 Then the SBITS word in the Semantics is updated to
00800 reflect the "In Core" status (e.g. CORTMP bit, fixup
00900 chain addr, etc.) The fixup chain may have originated
01000 in another temp entry, but was moved here to avoid searching
01100 up the Semantic stack for all who refer to this temp and
01200 changing the addresses of the entry they point to. WHAT????
01300
01400 PAR D contains AC # affected.
01500 SID LPSA, TEMP used
01600 ⊗;
01700
01800 ↑STORA: SKIPG LPSA,ACKTAB(D)
01900 POPJ P, ;NOTHING THERE.
02000 CAMN LPSA,ACKTAB-1(D) ;POSSIBLE DBLPRC SCREWUP?
02100 SOJA D,[PUSHJ P,STORA ;YES, STORE PRECEDING AC INSTEAD
02200 AOJA D,CPOPJ] ;AND RESTORE D
02300 PUSH P,SBITS
02400 PUSH P,TBITS ;SAVE YET ANOTHER AC
02500 MOVE SBITS,$SBITS(LPSA);GET SEMANTIC BITS.
02600 TLNN SBITS,INAC!PTRAC ;IF NOT IN AC, THEN TROUBLE
02700 ERR <STORA A THING NOT IN AC>,1
02800 ;; #KQ BY JRL (11-30-72) IGNORE FIXARS
02900 TLNN SBITS,FIXARR ;A FIXARR SHOULDN'T GET STORED
03000 TLNN SBITS,ARTEMP!DISTMP ;OTHERWISE A NOOP
03100 JRST ZER
03200 PUSH P,PNT
03300 PUSH P,A
03400 MOVEI PNT,(LPSA)
03500
03600 ;BUG TRAP
03700 HRRZ TEMP,$ACNO(PNT) ;THIS IS THE AC IT THINKS ITS IN.
03800 CAIE TEMP,(D) ;THE SAME
03900 ERR <STORA>,1
04000
04100 TLNE SBITS,DISTMP ;DISPLAY????
04200 JRST ZERDR ;YES
04300
04400 TLNE SBITS,CORTMP ;CAN WE PUT IT WHERE WE PUT IT BEFORE?
04500 JRST DEP ; YES (USUALLY ONLY HAPPENS WHEN SOME
04600 ; BUG PROVOKES IT --LIKE MISSING REMOP)
04700 RGC <
04800 TLNN SBITS,INDXED ;IF NOT INDXED TEMP
04900 JRST RCTCHK ;GO CHECK IF RECORD TEMP
05000 HRRZ TEMP,$VAL2(PNT) ;A SUBFIELD INDXED TEMP??
05100 JUMPE TEMP,NRML ;NO, JUST TREAT NORMALLY
05200 ;;#WX# ! JFR 6-5-76 FORGOT TO FETCH TBITS
05300 MOVE TBITS,$TBITS(PNT)
05400 ;;#WD# STRING SUBFIELD INDXED TEMPS ARE SPECIAL
05500 TDNN TBITS,[XWD SBSCRP,PROCED!ITEM!ITMVAR]
05600 ;;#WW# ! JFR 6-1-76 used to be TRNE (typo)
05700 TRNN TBITS,STRING
05800 JRST RCTMAK ;YES, DO THE OTHER SORT OF MOVEM
05900 JRST NRML ;HERE IF STR SUBF INDX TEMP
06000 ;;#WD# ↑
06100 RCTCHK: MOVE TBITS,$TBITS(PNT)
06200 TRNN TBITS,ITEM!ITMVAR ;THESE ARE ALWAYS NORMAL
06300 TRNN TBITS,PNTVAR ;A RECORD TEMP
06400 JRST NRML ;NOPE NORMAL
06500 RCTMAK: PUSHJ P,GETRCT ;GET A PNTVAR CORTMP
06600 JRST TMPCPY ;GO COPY FIXUPS,ETC
06700 NRML:
06800 >;RGC
06900
07000 SKIPA LPSA,TTEMP ;PREPARE TO SEARCH TEMP LIST
07100 TEML: LEFT ,%RVARB,NOFND ;GO DOWN TEMP LIST
07200 MOVE TEMP,$SBITS(LPSA)
07300 TLZE TEMP,INUSE ;NEED ONE NOT IN USE
07400 JRST TEML
07500 TLZN TEMP,CORTMP ;AND IN CORE
07600 JRST TEML ;REALLY AN ERROR
07700 TMPCPY: MOVE TEMP,$ADR(LPSA)
07800 MOVEM TEMP,$ADR(PNT) ; HO HO.
07900 MOVE TEMP,$PNAME(LPSA) ;ID NUMBER OF THIS CORTMP
08000 MOVEM TEMP,$PNAME(PNT) ;SO ADRINS AND SCOUT DON'T GET CONFUSED
08100 PUSHJ P,URGTMP ;REMOVE FROM RING
08200 FREBLK () ;THE OLD ONE
08300 JRST DEP1
08400
08500 NOFND: SETZM $ADR(PNT) ;WITH ZERO FIXUP
08600 ;; #JRL ALWAYS GIVE CORTMPS ID NO.
08700 AOS TEMP,TEMPNO ;CORTMP ID
08800 MOVEM TEMP,$PNAME(PNT)
08900 ;; #JRL
09000 DEP1: MOVE LPSA,PNT
09100 PUSHJ P,RNGTMP ;PUT ON RING
09200 DEP: MOVSI SBITS,CORTMP!INUSE!ARTEMP
09300 IORB SBITS,$SBITS(PNT) ;INDICATE THE NEW STATUS
09400 TURNOF: MOVSI LPSA,INAC!PTRAC!NEGAT ;TEMP NO LONGER IN AC
09500 ANDCAM LPSA,$SBITS(PNT)
09600 HRRM D,$ACNO(PNT) ;RECORD THE AC NUMBER
09700 HRLZI A,(<MOVEM>)
09800 TDNE TBITS,[SBSCRP,,PROCED!ITEM!ITMVAR]
09900 JRST .+3
10000 TRNE TBITS,DBLPRC
10100 MOVSI A,(<DMOVEM>)
10200 TLNE SBITS,INDXED ;A CALCULATED SUBSCRIPT?
10300 TRO A,ADDR ;YES -- DO NOT STORE INDIRECT.
10400 TLNE SBITS,NEGAT ;IS THE AC AROUND NEGATIVELY?
10500 JRST [HRLI A,(<MOVNM>) ;YES
10600 TRNE TBITS,DBLPRC
10700 HRLI A,(<DMOVNM>)
10800 JRST .+1]
10900 ;; #MD# ONLY STORE RIGHT HALF OF PTRAC
11000 TLNE SBITS,PTRAC
11100 HRLI A,(<HRRZM>) ;ONLY RIGHT HALF, IN CASE LATER AN
11200 ;INDIRECT MOVE IS DONE
11300 PUSHJ P,EMITER
11400 ;NOTE THOUGH THAT NEGAT MAY STILL
11500 ;BE ON. THIS MAY BE DANGEROUS.
11600 MOVEM SBITS,$SBITS(PNT)
11700 ZRET: POP P,A
11800 POP P,PNT
11900
12000 ZER:
12100 POP P,TBITS
12200 POP P,SBITS
12300 POPJ P, ;RETURN
12400 ZERDR: MOVE A,$VAL(PNT) ;ZEROING MASK
12500 HRR LPSA,$ADR(PNT) ;PICK UP DISPLAY LEVEL
12600 ANDM A,DISTAB(LPSA) ;ZERO APPROPRIATE SIDE OF DISTAB WORD
12700 HLLZS ACKTAB(D) ;ZONK THE ACKTAB ENTRY
12800 MOVE LPSA,PNT
12900 PUSHJ P,URGDIS ;UNLINK FROM DISPLAY VARB RING
13000 FREBLK (PNT)
13100 JRST ZRET
13200 SUBTTL CODE EMITTER
13300
00100 COMMENT ⊗EMITER -- Descriptions of Routine and Control Bits⊗
00200
00300 DSCR EMITER -- code emitting routine.
00400
00500 DES From input parameters and symbol table information,
00600 generate a word of real live code.
00700
00800 PAR
00900 A -- OPCODE in LH, bits in RH:
01000 NOUSAC←←400000 ;DON'T USE D(RH) AS AC #
01100 USCOND←←200000 ;USE C(RH) AS 3 BITS OF CONDITION
01200 USADDR←←100000 ;USE C(LH) AS DISPLACEMENT PART
01300 USX ←← 40000 ;USE D(LH) AS INDEX REG
01400 NORLC ←← 20000 ;RELOCATE NOT!
01500 IMMOVE←← 10000 ;IF OPERAND CONSTANT, LOAD IT ANY WAY POSSIBLE
01600 INDRCT←← 4000 ;INDIRECT ADDRESSING REQUIRED
01700 JSFIX ←← 2000 ;JUST DO A FIXUP (DON'T GET SEMANTICS).
01800 NOADDR←← 1000 ;NO EFFECTIVE ADDRESS PART
01900 ADDR ←← 400 ;WE WANT THE ADDRESS OF THIS ENTITY
02000 FXTWO←← 100 ;USE SECOND FIXUP WORD
02100
02200 C -- DISPLACEMENT (if provided) in LH, condition bits in RH
02300 D -- Index number in LH, AC number in RH (both optional)
02400 PNT -- symbol table pointer, if required
02500
02600 RES Code is written, RELOC bit is set to final value;
02700 Formal fixup list (FORMFX) has been updated, if necessary.
02800
02900 SID All Ac's are saved except TEMP and LPSA.
03000 ⊗;
03100
03200 BIT2DATA (EMITTER)
03300 INDIR ←← 20 ;THE INDIRECT BIT!!
03400 ;PNTROP ←← 200 ;THIS OPERATION WILL DO POINTER INDEXING
03500 ; (PURELY LOCAL BIT, BUT DON'T SEND IT IN)
03600 IMMED ←← 1000 ;THE IMMEDIATE BIT (FOR SOME THINGS).
03700
03800
03900 ↑XCALLQ:
04000 SKIPE NOEMIT
04100 POPJ P,
04200 PUSH P,C ;LITTLE ROUTINE
04300 HRL C,PCNT ;FOR CALLING LIBRARY ROUTINES.
04400 EXCH C,(A) ;FIXUP INTO LIBRARY TABLE.
04500 EMIT (<PUSHJ RP,NOUSAC!USADDR>)
04600 POP P,C
04700 POPJ P,
04800
04900
00100 COMMENT ⊗ EMITER Routine⊗
00200
00300 ↑EMITER:
00400 SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
00500 POPJ P, ; EXPR!TYPE)
00600 PUSH P,A ;SAVE THOSE THINGS WHICH MIGHT CHANGE
00700 PUSH P,C
00800 PUSH P,D
00900 PUSH P,TBITS
01000 PUSH P,SBITS
01100 TRZ A,PNTROP ;ASSUME NO POINTER OP
01200 ;;# # DCS 3-25-72 Eliminate bad array address problem
01300 ;;# # When [0,0,0]-word of array (location known, no fixup) falls
01400 ;;# # on reladr 0 of .REL file, CODOUT will mistake the 0 addr field
01500 ;;# # for end of fixup chain, will inhibit RELOC -- want RELOC in this
01600 ;;# # case. A bad fix, should be more generally solved.
01700 TLO FF,RELOC!FFTMP1 ;AND RELOC (FFTMP1 FOR CODOUT 0-TEST)
01800 ;;# #
01900 TRNE A,USADDR ;ADDR IN C(LH)?
02000 JRST EAC ;YES, BYPASS SEMANTICS TESTING
02100 TLZ FF,RELOC ;NOW ASSUME NO RELOCATION
02200 HRRZS C ;CLEAR DISPLACEMENT FLD -- C(LH)
02300 TRNE A,NOADDR ;IS THERE AN ADDRESS FLD AT ALL?
02400 JRST EAC ;NO, FINISH UP
02500 TRNE A,JSFIX
02600 JRST EVAR ;GO DO A FIXUP
02700
02800 ; NOW GET SEMANTICS AND DISPATCH TO CORRECT ROUTINE TO OUTPUT INSTR
02900
03000 MOVE SBITS,$SBITS(PNT)
03100 MOVE TBITS,$TBITS(PNT)
03200 ;; #JR# BY JRL 10-17-72 A STRING ITEM IS NOT A STRING
03300 TRNE TBITS,ITEM!ITMVAR
03400 TRZ TBITS,STRING!DBLPRC ;FORGET ABOUT STRING TYPE FOR ITEMS
03500 ;; #JR#
03600 NOSBS:
03700 NOREC <
03800 TRNN TBITS,PNTVAR ;IF PNTVAR OR INDXED OR
03900 >;NOREC
04000 TLNE SBITS,INDXED ; REFERENCE FORMAL,
04100 TRO A,PNTROP ;INDICATE A POINTER OPERATION
04200 TLNE TBITS,REFRNC
04300 TRO A,PNTROP
04400 TRNE A,ADDR ;IF ADDR and PNTROP, TURN OFF BOTH
04500 TRZE A,PNTROP ;(THE IMMEDIATENESS
04600 TRZ A,ADDR ; OF ADDR CANCELS THE INDIRECTNESS OF PNTROP
04700 TLNE TBITS,SBSCRP ;ELIMINATE FXTWO IF
04800 TRZ A,FXTWO ; ARRAY NAME
04900
05000 ;;#FP# 1-10-72 DCS (1-2)
05100 TLNE SBITS,INAC ;IN ACCUMULATOR?
05200 JRST EINAC
05300 ;;#FP#
05400 TLNE TBITS,FORMAL ;FORMAL PARAMETER (ACTUAL)?
05500 JRST EFORM ;
05600 TRNE A,PNTROP ;INDIRECTNESS DESIRED?
05700 JRST EPNT
05800 ;;#FP# 1-10-72 DCS (2-2)
05900 TLNE SBITS,PTRAC ;IN ACCUMULATOR? (WAS INAC TOO)
06000 JRST EINAC
06100 ;;#FP#
06200 TRNE A,ADDR ;SHOULD WE CONSIDER CONSTANT IMMED?
06300 JRST EVAR ;NO
06400 TLNE TBITS,CNST ;NUMERIC CONSTANT?
06500 TRNE TBITS,STRING ;
06600 JRST EVAR ; NO
06700
00100
00200 ECONST: TRNN TBITS,DBLPRC ;CANT OPTIMIZE LONG PRECISION
00300 SKIPE OPDUN ;NEVER OPTIMIZE USER INLINE CODE
00400 JRST EVAR ; BUT REFER TO MEMORY
00500 MOVE TEMP,$VAL(PNT) ;GET VALUE
00600 TRNN A,IMMOVE ;IMMEDIATE MOVE REQUESTED?
00700 JRST OPCON1 ; NO, TEST LH0
00800 HRLI A,(<MOVE >) ;ASSUME MOVEI
00900
01000 TLC TEMP,-1 ;TEST LEFT HALF -1
01100 TLCN TEMP,-1 ;IS IT?
01200 JRST [HRL C,TEMP ;YES, SET UP
01300 HRLI A,(<HRROI>) ; INSTR
01400 JRST EAC] ;AND EMIT IT
01500 TRNE TEMP,-1 ;RIGHT HALF ZERO?
01600 JRST OPCON1 ; NO
01700 MOVSS TEMP ;YES, SWAP HALVES
01800 TLO A,4000 ; AND TURN ON MOVSI BIT
01900 OPCON1: TLNE TEMP,-1 ;LEFT HALF ZERO?
02000 JRST EVAR ;NO
02100 HRL C,TEMP
02200 LDB TEMP,[POINT 9,A,8] ;GET OP-CODE
02300 SUBI TEMP,200 ;ONLY OPCODES IN RANGE <MOVE> (200)
02400 JUMPL TEMP,EVAR ; TO <OR> (434) WILL
02500 CAILE TEMP,234 ; BE CONSIDERED
02600 JRST EVAR
02700 PUSH P,USER
02800 IDIVI TEMP,=36 ;WORD # TO TEMP, BIT # TO USER
02900 MOVE TEMP,OPBTS(TEMP);SOME BITS
03000
03100 TABCONDATA (OPCODE BITS TABLE FOR EMITER OPTIMIZER)
03200 OPBTS: 421042004000 ;BIT ON IF
03300 000000104000 ;CORRESPONDING OPCODE
03400 776000000000 ;CAN BE IMMEDIATE
03500 ; OLD WORD OBPTS+3 ;REPLACED (6-27-73)
03600 ; 001040000000
03700 ;; #KAB INCORRECT AND MISSING OBPTS ENTRIES
03800 000000004200
03900 401040000000
04000 ;; #KAB#
04100 ENDDATA
04200
04300 LSH TEMP,(USER) ;THE RIGHT ONE
04400 POP P,USER
04500 JUMPGE TEMP,EVAR ;CAN'T OPTIMIZE, CODE WRONG
04600 CAML A,[CAM] ;THE COMPARES ARE MADE
04700 CAML A,[JUMP] ; IMMEDIATE BY TURNING OFF
04800 TLOA A,IMMED ; THE 10000 BIT, ALL OTHERS
04900 TLZ A,10000 ; BY TURNING ON THE 1000 BIT
05000 JRST EAC ;PUT OUT OPTIMIZED INSTR
05100
05200
05300
05400 EPNT: HRRE TEMP,$VAL(PNT) ;GET DISPLACEMENT IF ANY
05500 SUBI TEMP,1 ;ASSUME STRING AND ¬FXTWO
05600 ;;#UE# (3 OF 3) INDEXED STRING ARRAY TEMPS ARE LOSERS
05700 TLNE TBITS,SBSCRP ;IF AN ARRAY
05800 AOJA TEMP,EPNT.1 ;JUST REVERSE ASSUMPTION QUAM CELERIME
05900 ;;#UE# ↑
06000 TRNN TBITS,STRING
06100 ADDI TEMP,1 ;WAS NOT STRING
06200 TRZE A,FXTWO
06300 ADDI TEMP,1 ;WAS FXTWO
06400 EPNT.1: HRL C,TEMP ;GET TO DISPLACEMENT PLACE
06500 TLNE SBITS,PTRAC ;POINTER IN AC?
06600 JRST EACX ; YES
06700 TLNE C,-1 ;MAKE INDIRECT
06800 ERR <DRYROT AT EPNT>,1 ;UNLESS WE WANTED A DISPLACEMENT
06900 TRO A,INDRCT ;MAKE IT INDIRECT
07000 JRST EVAR ;GO DO FIXUPS
07100
07200 EACX: HRL D,$ACNO(PNT) ;USE AC AS INDEX
07300 TLNE TBITS,OWN ;IF ARRAY NAME COMES INTO IT,
07400 ;;# # DCS 3-25-72 Bad array address problem.
07500 TLC FF,RELOC!FFTMP1;RELOCATABLE, SHOUDN'T 0-TEST IN CODOUT
07600 ;;# #
07700 TRO A,USX ;DENOTE THAT IT SHLD BE DONE
07800 JRST CHKIMM
07900
08000 EINAC: HRL C,$ACNO(PNT) ;INAC, GET ACNO AS DISPL.
08100 TRNE TBITS,DBLPRC ;LONG
08200 TRNN A,FXTWO ;AND FXTWO
08300 JRST CHKIMM ; SEE IF ADDR IS ON
08400 ADD C,[1,,0] ;MEANS AC+1
08500 JRST CHKIMM
08600
08700 EFORM: TRO A,USX ;WILL NEED TO USE A STACK AS INDEX
08800 HRRZ TEMP,$ADR(PNT) ;GET DISPL FROM STACK TOP
08900 TDNN TBITS,[SBSCRP!REFRNC,,PROCED!ITEM!ITMVAR] ;THESE ARE NOT VALUE LONGS
09000 TRNN TBITS,DBLPRC ;LONG?
09100 JRST .+3 ;NO
09200 TRZE A,FXTWO
09300 SUBI TEMP,1 ;FXTWO ON LONG FORMAL MOVES CLOSER TO STACK TOP
09400 TLNE TBITS,REFRNC ;REFERENCE PARAM?
09500 JRST REFPRM ; YES
09600 VALPRM: TRNN TBITS,STRING ;STRING
09700 JRST REFPRM ;NO
09800 SKIPN SIMPSW
09900 TRNN SBITS,DLFLDM ;IF SIMPLE OR DL 0 THEN DO IT THE OOLD WAY
10000 JRST USERSP
10100 LDB LPSA,[LEVPOINT(SBITS)]; PICK UP LEVEL
10200 HLL D,DISTAB(LPSA) ;PICK UP REGISTER
10300 TLNN D,17
10400 ;;#MN# 7-13-73 THE FRIDAY 13 ACCESS KLUGE
10500 JRST [
10600 PUSH P,TEMP
10700 HLRZ TEMP,LSDRLV ;MAYBE THE THING IS STILL AROUND
10800 CAIE TEMP,(LPSA)
10900 ERR <DRYROT AT EFORM FOR STRING> ;BETTER NOT BE 0
11000 HLL D,LSDRNM ;GET THE OLD THING
11100 POP P,TEMP
11200 JRST .+1]
11300 ;;# #
11400 TRZE A,FXTWO ;IF SECONG WORD
11500
00100 SUBI TEMP,1 ;FIX IT
00200 MOVN TEMP,TEMP
00300 HRL C,TEMP ;USE THIS DISPL
00400 JRST CHKIMM ;GO CHECK
00500
00600 REFPRM: TLNN TBITS,SBSCRP ;IF SUBSCRIPTED AND
00700 JRST .+3 ; REFERENCE,
00800 TLNE TBITS,REFRNC ;
00900 TRZ A,PNTROP ;DO NOT GO INDIRECT.
01000 TRZE A,PNTROP ;WANT TO GET VALUE?
01100 TRO A,INDRCT ; YES, GO INDIRECT, FIND ON RP STACK
01200 LDB LPSA,[LEVPOINT(SBITS)];PICK UP DISPLY LEVEL
01300 CAIE LPSA,0 ;IF HAVE A DISPLAY
01400 JRST USEDRF ;USE IT
01500 MOVE LPSA,TPROC ;PICK UP PROC ID
01600 HRRZ LPSA,$SBITS(LPSA);PICK UP RH OF SBITS FOR PROC
01700 ADDI LPSA,1 ;WANT LEVEL OF FORMLS
01800 XOR LPSA,SBITS ;ALL THIS IS A FANCY TEST TO SEE IF THIS PROC'S
01900 TRNE LPSA,LLFLDM ;IS IT THE SAME
02000 ERR <INACCESSABLE FORMAL> ;NO
02100 SKIPN SIMPSW ;BETTER BE SIMPLE PROC
02200 ERR <DRYROT AT EPNT -- SIMPLE?> ;YOU FUCKED UP
02300
02400
02500 USERP: HRLI D,RP ;MARK THIS STACK
02600 ADD TEMP,ADEPTH ;TOTAL ARITH STACK DEPTH
02700 JRST MAKFRM ;GO CREATE FORMAL REF INSTR
02800
02900 USERSP: HRLI D,RSP
03000 ADD TEMP,SDEPTH
03100 TRZE A,FXTWO ;SECOND WORD?
03200 SUBI TEMP,1 ;YES, DON'T GO SO FAR
03300
03400 MAKFRM: MOVNS TEMP ;NEGATIVE STACK DISPLACEMENT
03500 HRL C,TEMP ;USE THIS DISPLACEMENT
03600 ;;#KH# RHT (11-21-72) DELETED LARGE HUNKOF LEFT OVER STUFF FROM FORMFX
03700 JRST CHKIMM ;FINISH OUT
03800 USEDRF: HRL D,DISTAB(LPSA) ;PICK UP DISPLAY REGISTER
03900 TLNN D,-1 ;WAS IT LOADED
04000 ;;#MN# FRIDAY 13 JULY
04100 PUSHJ P,[DRKLUG:
04200 PUSH P,TEMP
04300 HRRZ TEMP,LSDRLV
04400 CAIE TEMP,(LPSA) ;OLD LEVEL THERE???
04500 ERR <DRYROT AT EFORM>,1;NO
04600 POP P,TEMP
04700 HRL D,LSDRNM
04800 POPJ P, ]
04900 ;;# #
05000 MOVN TEMP,TEMP ;NEGATE DISPL
05100 SUBI TEMP,1 ;SINCE RF IS ONE MORE AWAY
05200 HRL C,TEMP ;USE IT
05300 JRST CHKIMM ;GO FINISH UP
05400
05500 EVAR:
05600 TLO FF,RELOC ;NOW ASSUME RELOC AGAIN
05700 ;;#VM# ! JFR 10-30-75 PARANOIA THAT PROCEDURES COULD SLIP THROUGH
05800 TRNN TBITS,PROCED
05900 TRNE A,JSFIX ;IF JUST WANT A FIXUP
06000 JRST USECR ;THEN THATS ALL YOU GET
06100 TLNE SBITS,CORTMP ;IS IT A CORE TEMP
06200 JRST [ ;YES
06300 SKIPN RECSW ;IF NOT RECURSIVE PROC THEN
06400 JRST USECR ;USE A CORE LOCN -- NO DR NEEDED
06500 MOVE LPSA,CDLEV ;USE THIS LEVEL
06600 JRST USED.1 ;NO LDB ALLOWED
06700 ]
06800 TRNE SBITS,DLFLDM ;STACK VAR?
06900 JRST USEDR ;YES
07000 USECR:
07100 HRL C,$ADR(PNT) ;ADDR OR LAST FIXUP
07200 DCDFX: TRNN A,JSFIX
07300 TRNE TBITS,FORWRD!INPROG ;MUST FIXUP IF EITHER IS ON
07400 JRST DOFIX
07500 TLNN SBITS,FIXARR ;DON'T FIXUP IF FIXARR ON
07600 TRNE TBITS,PROCED!LABEL ;ELSE ONLY IF NEITHER OF THESE
07700 JRST DONTFX
07800 REC <
07900 TRNE TBITS,PNTVAR ;CHECK FOR CLASS ID
08000 TRNN TBITS,SHORT ; IE SHORT PNTVAR
08100 JRST DOFIX
08200 JRST DONTFX ;CLASS ID NOT FIXED UP
08300 >;REC
08400 NOREC <
08500 JRST DOFIX ;HERE DO IT
08600 >;NOREC
08700
08800 USEDR: LDB LPSA,[LEVPOINT<SBITS>] ;GET DISPLAY LEVEL
08900 USED.1: HRL D,DISTAB(LPSA) ;USE DISPLY REG
09000 TRNE TBITS,STRING ;UNLESS STRING
09100 JRST [
09200 ;#IO# RHT 7-17-72 ATTEMPT TO USE STR DR FOR A INDEXED TEMP
09300 TLNE SBITS,INDXED ;DONT IF RESULT OF ARRAY CALC
09400 JRST .+1 ;
09500 ;# #
09600 TLNN TBITS,SBSCRP ;DONT FOR ARRAYS
09700 HLL D,DISTAB(LPSA) ;CODED THIS WAY TO HANDLE USUAL CASE
09800 JRST .+1]
09900 TRNE A,USX ;BETTER NOT PLAN TO INDEX THIS
10000 ERR <DRYROT AT EVAR>,1 ;NO
10100 TLNN D,-1 ;WAS IT LOADER
10200 ;;#UV# JFR 8-16-75 WHAT A HACK.
10300 PUSHJ P,DRKLUG ;FIX RACE CONDITION. GET (ACCESS)
10400 ;FOUND THE DISPLAY REG, BUT ACCOP USED THE REG SINCE
10500 ;ALL OTHERS WERE BUSY. HACK, HACK.
10600 HRL C,$ADR(PNT) ;PICK UP DISPL
10700 TRO A,USX ;USE THE MOTHER
10800 JRST DCDFX ;GO THINK ABOUT FIXING UP
10900
11000
00100
00200 DOFIX: HRRZ TEMP,PCNT ;READY TO DO FIXUP CHAINING
00300 TRZE A,FXTWO ;USE SECOND FIXUP ADDR
00400 JRST [HLL C,$ADR(PNT)
00500 HRLM TEMP,$ADR(PNT) ;YES, MATTER OF FACT
00600 JRST CHKIMM]
00700 HRRM TEMP,$ADR(PNT) ;FINISH FIXUP CHAINING
00800
00900 DONTFX:
01000 TLNN SBITS,FIXARR
01100 JRST CHKIMM
01200 ;;#YY# JFR 2-12-77 MAKE LOGIC CLEARER AND FXTWO OF LONG DO THE RIGHT THING
01300 ;; SUB C,[XWD 1,0] ;ASSUME STRING, NOT FXTWO
01400 ;; TRNE TBITS,STRING ;IF NOT STRING OR IF FXTWO,
01500 ;; TRZE A,FXTWO
01600 ;; ADD C,[XWD 1,0] ; NULLIFY ASSUMPTION
01700 TRZE A,FXTWO
01800 ADD C,[XWD 1,0] ;FXTWO, SO 2ND WD
01900 TRNE TBITS,STRING
02000 SUB C,[XWD 1,0] ;EXCEPT STRINGS HAVE ORIGIN AT -1
02100 ;;#YY# ↑
02200 CHKIMM:
02300
02400 TRNN A,ADDR ;DO WE WANT THIS POINTER RAW?
02500 JRST EAC ; NO, FINISH UP
02600 TLO A,IMMED ;THE ONLY WAY TO DO IT HERE IS TO
02700 TRNE A,USCOND ; MAKE THE INSTR IMMEDIATE
02800 HRLI A,(<CAI>) ; (CONDITIONAL MUST BE A CAM)
02900
03000 EAC: TRNE A,INDRCT ;INDIRECT BIT WANTED?
03100 TLO A,INDIR
03200 TRNN A,NOUSAC ;AC FLD PROHIBITED?
03300 DPB D,[POINT 4,A,12] ;NO, PUT IT IN
03400 TRNE A,NORLC ;RELOCATION PROHIBITED?
03500 TLZ FF,RELOC ; YES, TAKE IT OUT
03600 TRNE A,USCOND ;CONDITION BITS NEEDED TO FINISH OPCODE
03700 DPB C,[POINT 3,A,8] ;YES, DO IT
03800 TRNE A,USX ;D(LH) TO BE USED AS INDEX FLD?
03900 TDO A,D ;YES (WIPES OUT A(RH))
04000 HLR A,C ;GET DISPL (SO DOES THIS)
04100 ;;# # DCS 3-25-72 bad array address problem
04200 MOVEI TEMP,CODOUT ;STANDARD CASE
04300 TLNN FF,FFTMP1 ;IF THIS BIT GOT TURNED OFF, CODREL SHOULD
04400 MOVEI TEMP,CODREL ; BE CALLED TO AVOID THE 0-TEST WHICH
04500 PUSHJ P,(TEMP) ; WOULD INHIBIT RELOC -- PUT OUT THE CODE
04600 ;;# #
04700 POP P,SBITS
04800 POP P,TBITS
04900 POP P,D
05000 POP P,C
05100 POP P,A
05200 ;;#MN# 7-13-73
05300 SETZM LSDRLV ;REALLY ONLY NEED TO ZERO THIS
05400 SETZM LSDRNM ;REALLY WILL DO THIS ANYHOW
05500 ;;# #
05600 POPJ P, ;RESTORE AND RETURN
05700 SUBTTL Generalized push and pop.
05800
00100 COMMENT ⊗Qstack Routines -- BPUSH, etc.⊗
00200
00300 DSCR QSTACK ROUTINES
00400 DES These are routines to provide generalized, expandable push-
00500 down stacks (buffers? queues?) for use by algorithms which need
00600 widely varying storage, accessed in simple ways. Such structures
00700 are called QSTACKS, and are built out of Semblks as follows --
00800
00900 WORD1 -- ptr to PREV,,ptr to NEXT
01000 WORDS 2-11 -- up to 10 words of "stack" data
01100
01200 A stack is identified by its QPDP, or Qstack Descriptor, which is --
01300 ptr TOP,,ptr Semblk containing TOP
01400
01500 Most Qstack operations reference the address where this QPDP (there
01600 should be one QPDP which always refers to the TOP) is stored. Others
01700 may also be used in conjunction with Qstack operations
01800
01900 Qstack operations are provided to PUSH data on, POP data off (these
02000 allocate and release Semblks, if necessary, and change the TOP QPDP),
02100 access data non-destructively in forward and reverse directions, and
02200 to clear a given Qstack.
02300 ⊗
02400
02500 DSCR BPUSH
02600 CAL PUSHJ via QPUSH macro
02700 PAR LPSA ptr to QPDP for Qstack
02800 A is data to be pushed
02900 RES QPDP is updated, A is stored in Qstack, new Semblk if necessary
03000 DES if QPDP is 0, an initial Semblk is created, QPDP constructed.
03100 SID only TEMP is changed
03200 SEE QPUSH
03300 ⊗
03400
03500 ↑BPUSH: PUSH P,A ;SAVE IT.
03600 SKIPN TEMP,(LPSA) ;THE CURRENT POINTER
03700 JRST NEWONE ;NONE YET, GUYS.
03800 HLRZ A,TEMP
03900 CAIL A,BLKLEN-1(TEMP) ;GONE OVER BLOCK BOUNDARY?
04000 JRST NOTHER ;YES
04100 PUSH1: PUSH A,(P) ;SEE !!!
04200 HRLM A,(LPSA) ;CURRENT POINTER UPDATED.
04300 POP P,A ;RESTORE
04400 POPJ P, ;DONE
04500
04600 NEWONE: PUSH P,LPSA
04700 GETBLK ;GET A NEW BLOCK.
04800 SETZM (LPSA)
04900 MOVE TEMP,LPSA ;POINTER TO NEW BLOCK.
05000 POP P,LPSA
05100 MORBLK: HRRM TEMP,(LPSA) ;UPDATE PDP POINTER.
05200 HRRZ A,TEMP
05300 JRST PUSH1 ;FINISH OUT.
05400
05500 NOTHER: PUSH P,LPSA ;SAVE IT
05600 GETBLK
05700 MOVE TEMP,LPSA ;POINTER TO NEW ONE.
05800 POP P,LPSA
05900 HRRZ A,(LPSA) ;PDP POINTER.
06000 HRLZM A,(TEMP) ;SAVE LINKS IN NEW BLOCK.
06100 HRRM TEMP,(A) ;AND IN PDP
06200 JRST MORBLK
06300
00100
00200 DSCR BPOP
00300 CAL PUSHJ via QPOP macro
00400 PAR LPSA ptr to QPDP
00500 RES A ← data from TOP, QPDP is updated
00600 DES Semblks are released as they are emptied
00700 SID only TEMP, A are changed
00800 ERR if there is no QPDP, or if no more data, error
00900 SEE QPOP
01000 ⊗
01100
01200 ↑BPOP: SKIPN TEMP,(LPSA) ;PDP POINTER
01300 ERR <DRYROT -- BPOP>
01400 HLRZ A,TEMP
01500 POPMOR: SUBI A,1 ;THIS IS A POP
01600 CAIGE A,(TEMP) ;GONE BELOW THIS BLOCK?
01700 JRST POPBAK ;YES ALAS
01800 HRLM A,(LPSA) ;UPDATE PDP
01900 MOVE A,1(A) ;THIS IS THE RESULT.
02000 POPJ P,
02100
02200 POPBAK: PUSH P,TEMP
02300 HLRZ TEMP,(TEMP) ;BACKWARD POINTER.
02400 PUSH P,TEMP
02500 FREBLK <-1(P)> ;DELETE THE BLOCK.
02600 POP P,TEMP
02700 POP P,(P) ;INGNORE THIS.
02800 SKIPN TEMP ;IS IT THERE?
02900 ERR <DRYROT -- BPOP>
03000 HLLZS (TEMP) ;ZERO FORWARD POINTER
03100 MOVEM TEMP,(LPSA) ;UPDATE PDP
03200 MOVEI A,BLKLEN-1(TEMP) ;NEW MAX.
03300 JRST POPMOR ;FINISH OUT.
03400
03500
03600 DSCR QTAK
03700 CAL PUSHJ, via QTAKE macro
03800 PAR B is QPDP for data word preceding one desired
03900 LPSA ptr QPDP for this QSTACK
04000 RES if there is more data (check via LPSA ptr):
04100 B is updated as if it were a BPUSH QPDP
04200 A receives value of TOP
04300 BTAK skips
04400
04500 if there is no more data:
04600 nothing is changed
04700 BTAK does not skip
04800 SID only A,B, TEMP changed
04900 SEE QTAKE macro
05000 ⊗
05100 ↑QTAK: CAMN B,(LPSA) ;OVERFLOW?
05200 POPJ P, ;YUP
05300 HLRZ TEMP,B
05400 CAIL TEMP,BLKLEN-1(B) ;OVERFLOW OF OTHER TYPE?
05500 JRST NEXTBL ;YES
05600 TAKMOR: MOVE A,1(TEMP)
05700 HRLI B,1(TEMP)
05800 AOS (P)
05900 POPJ P,
06000
06100 NEXTBL: HRRZ B,(B) ;GO FORWARD
06200 HRRZ TEMP,B ;NOTE THAT THE BLOCKS ARE
06300 JRST TAKMOR ;NOT DELETED !!!!!!
06400
00100
00200 DSCR BBACK
00300 CAL PUSHJ via QBACK macro
00400 PAR B contains QPDP
00500 RES B is "popped"
00600 A receives data from TOP word
00700 if there was data left, skip-returns -- else no-skip
00800 SID only A, TEMP, B changed
00900 SEE QBACK
01000 ⊗
01100 ↑↑BBACK: HLRZ A,B ;ptr to TOP, ACCORDING TO B'S QPDP
01200 BTMOR: SUBI A,1 ;TRY THE "POP"
01300 CAIGE A,(B) ;WAS THERE DATA LEFT HERE?
01400 JRST BTBAK ;NO, BACK UP
01500 HRLM A,B ;UPDATE B'S QPDP
01600 MOVE A,1(A) ;FETCH "TOP" ELEMENT
01700 AOS (P) ;SUCCESS UNLESS SOSED BY BTBAK
01800 QPOPJ: POPJ P, ;DONE
01900
02000 BTBAK: HLRZ B,(B) ;BACK UP
02100 JUMPE B,QPOPJ ; NO MORE DATA
02200 MOVEI A,BLKLEN-1(B) ;RESET LH PTR
02300 JRST BTMOR ;FINISH UP
02400
02500 DSCR BFLUSH
02600 CAL PUSHJ, via QFLUSH macro
02700 PAR LPSA ptr to QPDP
02800 RES all Semblks cleared, QPDP zeroed
02900 SID A, B, TEMP changed
03000 SEE QFLUSH
03100 ⊗
03200 ↑↑BFLUSH: SKIPN A,(LPSA)
03300 POPJ P, ;NO STACK
03400 FLSHLP: HLRZ B,(A) ;GET NEXT PTR
03500 FREBLK (A) ;RELEASE TOP SEMBLK
03600 MOVE A,B
03700 JUMPN A,FLSHLP ;MAKE NEXT ONE BACK TOP ONE
03800 SETZM (LPSA) ;ALL DONE
03900 POPJ P,
04000
04100 DSCR BBEG
04200 CAL PUSHJ, via QBEGIN macro
04300 PAR B is QPDP
04400 RES B is QPDP which, when BTAKEd, returns first element in Qstack
04500 B is 0 if no Qstack exists
04600 SID only B, TEMP changed
04700 SEE QBEGIN
04800 ⊗
04900 ↑↑BBEG: SKIPN B,(LPSA) ;IS THERE A STACK?
05000 POPJ P, ; NO
05100 LOPPP: HRLS B ;MAKE INIT QPDP FOR THIS SEMBLK
05200 HLRZ TEMP,(B) ;GET BACK PTR
05300 JUMPE TEMP,CPOPJ ;WHEN HAVE REACHED FIRST SEMBLK, QUIT
05400 MOVE B,TEMP ;TRY AGAIN
05500 JRST LOPPP
05600
00100 COMMENT ⊗PWR2⊗
00200
00300 DSCR PWR2
00400 DES Tests number in register B for being a power of 2.
00500 if so, it skip-returns (********) and C
00600 has a small integer representing the power.
00700
00800 SID AC'S: uses TEMP
00900 ⊗;
01000 ↑PWR2: JUMPLE B,CPOPJ ;ROUTINE TO TEST B FOR A POWER OF TWO.
01100 MOVN TEMP,B ;TWO'S COMPLEMENT.
01200 AND TEMP,B ;AND THE AND
01300 TLNN B,777000 ;TOO BIG ?
01400 CAME TEMP,B ;THE MAGIC TEST FOR POWER OF TWO.
01500 POPJ P, ;NO DICE.
01600 FSC B,233 ;NOW THE NORMALIZE.
01700 ASHC B,-=44 ;NOW CORRECTLY IN C. (LEFT HALF)
01800 SUB C,[XWD 201,400000]
01900 AOS (P)
02000 POPJ P,
02100
02200
02300 SUBTTL Generator Output Routines.
02400
00100 COMMENT ⊗GBOUT Description, Loader Block Format Description⊗
00200
00300 DSCR GBOUT -- write a block of binary output
00400 DES
00500 One of the specialized output routines has produced
00600 a loader block, ready for output. These
00700 routines are:
00800
00900 CODOUT -- prepares a code block. Each call
01000 puts a word of code into a buffer and sets relocation
01100 appropriately.
01200
01300 FBOUT -- prepares a fixup block. Each call puts a fixup word into
01400 a buffer.
01500
01600 SOUT -- for outputting symbols. Each call puts a symbol
01700 name (in RADIX50) and an address into a buffer.
01800
01900 Other parts of the generators also call GBOUT for special functions
02000 (entry block, prog name block, etc). The routines
02100 call GBOUT when their buffers are full or when they
02200 wish to force out all of a given block.
02300
02400 Each block outputted by GBOUT has the same general format:
02500 WD1: BLOCK TYPE,,COUNT
02600 0 LEQ COUNT (WDn-WD3+1) LEQ 18
02700 WD2: relocation bits
02800 18 2-bit bytes (left-justified) corresponding
02900 to the 18 (maximum) data words in the block.
03000 The first bit of each is on if the left
03100 half is to be relocated. The second bit
03200 of each corresponds to the right half
03300 of its data word.
03400 WD3: first data word
03500 .
03600 .
03700 .
03800 WDn: last data word 2 LEQ n LEQ 20
03900
04000 The Binary file is opened and initialized in the command
04100 scanner (outer block of SAIL). The FF bit BINARY
04200 is on if a binary output is desired (if the file is open).
04300
04400 PAR B -- SIZE,,address of loader block
04500 SIZE is size of ENTIRE block (2 + WD1's count)
04600 It is zero if WD1's COUNT is to be believed.
04700
04800 RES The block is written if SIZE is GEQ 3
04900
05000 SID All ACS are preserved
05100 ⊗;
05200
00100 COMMENT ⊗ Control Variables for Loader Block Output⊗
00200
00300 ZERODATA (REL-FILE OUTPUT VARIABLES)
00400
00500 ;CODPNT -- bp for relocation bits in BINTAB CODE block
00600 ; see GBOUT for details about relocation bits -- initted to --
00700 ?CODPNT: POINT 2,BINTAB+1
00800
00900 ;FRSTSW -- off until first word of code goes out -- used to
01000 ; trigger output of program name block, initial code, etc.
01100 ; in CODOUT -- set on in CODOUt
01200 ?FRSTSW: 0
01300
01400 ;FXPNT -- reloc bits bp for FXTAB FIXUP block -- see FBOUT, GBOUT
01500 ?FXPNT: POINT 2,FXTAB+1
01600
01700 ;LSTRAD, LSTRLC, LSTWRD -- last radix50 word output, last code
01800 ; word output, last relocation bits output -- used by Boolean
01900 ; and ALLOT code, for repeating some of it
02000 ↑↑LSTRAD: 0
02100 ↑↑LSTRLC: 0
02200 ↑↑LSTWRD: 0
02300
02400 ;OUTADR -- bp set up by GBOUT for fetching words from LODBLKs
02500 ; for transfer to output buffer
02600 ?OUTADR: 0
02700
02800 ;RAD5. -- RADIX50 creates a value corresponding to a symbol comprising
02900 ; the first 5 characters of the identifier, followed by ".", in
03000 ; addition to each value it creates. It is saved here, used sometimes.
03100 ↑↑RAD5.: 0
03200 ↑↑RAD5$: 0 ;SIMILAR, BUT WITH A $
03300 ↑↑RAD5%: 0 ;GUESS WHAT
03400 ;SMPNT -- reloc bits pb for SMTAB SYMBOLS block -- see SCOUT, GBOUT
03500 ?SMPNT: 0
03600
03700 DATA (REL-FILE OUTPUT VARIABLES)
03800
03900 ;SALIB -- used to place main SAIL library request in LBTAB output
04000 ; loader block -- see DONES, PRGOUT
04100 ;SALIH -- re-entrant version of library
04200
04300 ↑SALIB: LIBLEN ;STRING CONSTANT, LIBLEN LONG
04400 ;;#HX# 6-24-72 DCS PARAMETERIZE LIBRARY NAMES
04500 POINT 7,[LIBLOW]
04600 REN <
04700 ↑SALIBH:LIBLEN
04800 POINT 7,[LIBHI]
04900 ;;#HX#
05000 >;REN
05100
05200 BAIL<
05300 ↑BAIREL: BALENG ;STRING CONSTANT, BALENG LONG
05400 POINT 7,[BAILOD]
05500 ↑BAIPD: BPDALN ;STRING CONSTANT
05600 POINT 7,[BAIPDS]
05700 >;BAIL
05800
00100 COMMENT ⊗ Loader Output Blocks-- Entry, Program Name, Initial Stuff⊗
00200
00300 DATA (LOADER OUTPUT BLOCKS)
00400 COMMENT ⊗
00500 Here are the loader output blocks. They are formatted as described
00600 in SAILON ;;.; by Bill Weiher. The general routine GBOUT handles
00700 the actual output of these (filled) blocks to the .REL file. For
00800 several of the block types, special routines exist below (CODOUT,
00900 FBOUT, etc.) to place individual words (and their relocation) into
01000 the blocks, and to call GBOUT when a block is full
01100 ⊗
01200
01300
01400 COMMENT ⊗
01500 ENTTAB -- ENTRY block -- names included in SAIL ENTRY statements.
01600 This must be the first block out (due both to syntax and
01700 necessity. It allows the .REL file to be used as part
01800 of a library.
01900 ⊗
02000 LODBLK (ENTRY,4,ENTTAB,,=18)
02100
02200
02300 COMMENT ⊗
02400 PROGNAM -- PROGRAM NAME BLOCK -- output of this block is delayed until
02500 first word of code goes out, to give user longest possible time
02600 to come up with a program name. Must go out before code to name
02700 outer block symbols and labels and stuff.
02800 ⊗
02900 ;;%CL% JFR 7-22-75 IDENTIFY OURSELVES TO LINK-10
03000 LODBLK (PROGNAM,6,BEGNAM,BEGCNT,2)
03100 RELOC .-2
03200 ↑↑PRGTTL: RADIX50 0,M ;DEFAULT NAME, IF NO OTHER COMES
03300 XWD 7,0 ;7 means SAIL, bits 0-5 tell hardware assumptions
03400 ;;%CL% ↑
03500
03600 COMMENT ⊗
03700 HBLK -- High Segment Block -- Denotes Re-entrant Output
03800 ⊗
03900 REN <
04000 LODBLK (HIGH,3,HBLK,HBLK2,1,,<XWD 200000,0>)
04100 RELOC .-1
04200 XWD 400000,400000 ;TWOSEG
04300 >;REN
04400
04500
04600
04700 COMMENT ⊗
04800 BEGOUT -- STANDARD INITIAL CODE SEQUENCE
04900 This code is always put out, but is only executed (and fixups
05000 are only correct) for Main Programs. Sample fixed-up code is
05100 included in the comments
05200 ⊗
05300
05400
05500 LODBLK (CODE,1,BEGOUT,BEGCT2,10,,<XWD 200000,0>)
05600 RELOC .-10
05700
05800 ↑↑BEGPC:0 ;PC ALWAYS 0 OR 400000
05900 SKIPA ;NOT STARTED IN RPG
06000 SETOM ;RPGSW
06100 JSR ;SAILOR
06200 ;;%AL% THE HRLOI IS NOW DONE BY SAILOR
06300 ;; HRLOI RF,1 ;FOR FIRST LINK
06400 PUSH P,RF
06500 PUSH P, ;[PDA,,0]
06600 PUSH P,SP
06700 HRRI RF,-2(P); SET F
06800
06900
07000
00100 COMMENT ⊗ Code, Boolean Code, Fixups, Links⊗
00200
00300 COMMENT ⊗
00400 BINTAB -- MAIN CODE BLOCK
00500 All generated instructions are output via CODOUT-GBOUT
00600 to this block. See CODOUT for details
00700 ⊗
00800 LODBLK (CODE,1,BINTAB,,=18)
00900
01000
01100 COMMENT ⊗
01200 BOLOUT -- SPECIAL BOOLEAN CODE BLOCK
01300 Conditionals are output once when a condition is seen, and
01400 again (with fixups and compare op codes correct) when the
01500 entire Boolean expression has been parsed and analyzed.
01600 See BOOLEAN for details.
01700 ⊗
01800 LODBLK (CODE,1,BOLOUT,,0,,<XWD 200000,0>)
01900 ↑↑BRELC←.-1 ;TO ACCESS RELOCATION BITS
02000 ↑↑BPCNT: 0 ;PROGRAM COUNTER -- SAME AS WHEN INSTRS FIRST OUT
02100 ↑↑BWRD1: 0 ;COMPARE, SKIP, OR CONDITIONAL JUMP
02200 ↑↑BWRD2: 0 ;UNCONDITIONAL JUMP IF BWRD1 WAS A COMPARE OR SKIP
02300 ↑↑BWRD3: 0
02400
02500
02600 COMMENT ⊗
02700 FXTAB -- FIXUPS
02800 Each word contains in its right half the address or stack
02900 displacement (reloc bits adj. accordingly) of a variable
03000 or instruction. The left half contains the address
03100 (relative to 0, of course) of the last instruction or data
03200 which requires this address field. This location, in turn,
03300 was compiled to refer to the next previous use of the variable
03400 or whatever... in other words, a fixup chain (terminates in 0).
03500 The LOADER uses these fixups to handle forward references to
03600 things. See FBOUT for details
03700 ⊗
03800 LODBLK (FIXUPS,10,FXTAB,,=18,-1)
03900
04000
04100 COMMENT ⊗
04200 SMTAB -- SYMBOLS
04300 All local and internal symbols, and global requests, are output
04400 through this block. See SCOUT and friends for details.
04500 ⊗
04600 LODBLK (SYMBOLS,2,SMTAB,,=18,<XWD 42104,210421>)
04700 ;(RELOCATE EVERY OTHER WORD -- GENERALLY)
04800
04900
05000 COMMENT ⊗
05100 SLNKBK -- LINK BLOCKS
05200 The string link, space link, and other links are output
05300 through this block. These links provide inter-RELfile
05400 communication (best example is link that chains all string
05500 variables together, so that STRNGC can get at them. See
05600 LNKOUT for details.
05700 ⊗
05800 LODBLK (LINK,12,SLNKBK,SDSCRP,2,,<XWD 40000,0>)
05900 RELOC .-2
06000 ↑↑LNKNM: 1 ;USUALLY STRING LINK, BY CONVENTION #1
06100 ;SPACE LINK IS #2
06200 ;SET LINK IS #3
06300 ;STRNGC ROUTINE NAMES LINK IS #4
06400 ; THESE ARE SAIL CONVENTIONS ONLY
06500 ↑↑SLNKWD: 0 ;ADDRESS OF ELEMENT OF CHAIN
06600
00100 COMMENT ⊗ Space Allocation Block
00200
00300 SBCTBL -- SPACE ALLOCATION BLOCK
00400 In this block is collected all REQUIRE specifications
00500 (except LOAD!MODULES, LIBRARIES, SOURCE!FILES) and
00600 space limits (string space, system pdl, new items, etc.)
00700 It is output as a code block. Also output is a link
00800 block tying this space block to all the others loaded
00900 together. The SAILOR (initialization) routine uses this
01000 information to provide an environment pleasing to the user.
01100 See DONES and the REQUIRE code for more details. Also GOGOL
01200 (%ALLOC) for block format explanations
01300 ⊗
01400 ;;%BR% RHT ALLOW COMVER THING FOR EVERYONE (BUT KEEP EXPO FOR NOW)
01500 ↑↑SPCSIZ←←=17 ;$SPREQ+1 ;IF EVER MAKE 18 OR MORE, MUST CHANGE SOME THINGS
01600 ;;↑↑SPCSIZ←←=14 ;BAD OLD VALUE *****
01700 ;;%BR% ↑
01800
01900 ↑↑SPCTBL:XWD 1,SPCSIZ ;CODE BLOCK, AT LEAST SPCSIZ LONG
02000 BYTE (2) 1,0,0,0,0,1,0,0,0,0,0,0,1,1,0,1
02100 ;PC WORD,MESLNK,TINIT,PINIT,OBPDA(RELOC)
02200 ↑SPCPC: 0 ;PC LOCATION
02300 0 ;LINK BLOCK PROVIDES CHAIN THROUGH THIS LOC
02400 ;; %AG% HAVE ITEMNO KEEP BOTH MIN AND MAX
02500 ↑ITEMNO:0 ;MIN,,MAX ITEM NUMBER DECLARED THIS COMPILATION
02600 ↑NWITM: 0 ;REQUIRE n NEW!ITEMS PUTS n HERE
02700 ;; %AG% ! HAVE GITEMNO CONTAIN LEAPIS FLAG
02800 ↑GITEMNO:0 ;XWD LEAPIS,MAX (MIN?) GLOBAL ITEM NUMBER DECLARED
02900 ↑MESLNK:0 ;POINTER TO MESSAGE PROCEDURE LIST PUT HERE
03000 ↑PNAMNO:0 ;REQUIRE n PNAMES PUTS n HERE
03100 ↑VERNO: 0 ;REQUIRE n VERSION PUTS n HERE
03200 ↑SEGNAM:0 ;REQUIRE "name" SEGMENT!NAME PUTS "name" HERE IN SIXBIT
03300 ↑SEGDEV:0 ;REQUIRE "dev:file[p,pn]" SEGMENT!FILE PUTS
03400 ↑SEGFIL:0 ; dev, file, ppn IN THESE LOCS IN SIXBIT
03500 ↑SEGPPN:0 ;(LOW BIT OF DEV IS SEGMENT PROTECT BIT, NOT USED NOW)
03600 ↑TINIT: 0 ;INITIALIZATION BLOCK ADDRESS FOR DECLARED ITEM TYPES
03700 ↑PINIT: 0 ;INIT. BLOCK FOR PNAMES(DECLARED ITEMS)
03800 ;;%BR%
03900 ↑↑COMVER: 0 ;NICE THING, BUT SUAI
04000 ;;%BV% !
04100 ↑↑OBPDA:0 ;OUTER BLOCK PDA
04200 0 ;SPARE
04300 ;;%BR% ↑
04400 BLOCK 50 ;ROOM FOR MORE REQUESTS
04500 ↑SPCEND←←.-1
04600
04700
04800
00100 COMMENT ⊗ Request Blocks -- RELfile, Libraries⊗
00200
00300 COMMENT ⊗
00400 PRGTAB -- RELFILE REQUEST BLOCK
00500 REQUIRE "...." LOAD!MODULE generates one of these. The LOADER
00600 loads all requested .REL files after loading all the explicit
00700 stuff. See REQUIRE code for details
00800 ⊗
00900 ;; #KS# ADD LOADVR SWITCH
01000 IFN (LOADVR-=54), <
01100 LODBLK (RELREQ,15,PRGTAB,,=18)
01200 >
01300 IFE (LOADVR-=54), <
01400 LODBLK (RELREQ,16,PRGTAB,,=18)
01500 >
01600 ;; #KS#
01700
01800 COMMENT ⊗
01900 LBTAB -- LIBRARY REQUEST BLOCK
02000 REQUIRE "...." LIBRARY generates one of these (SAIL main programs
02100 automatically request SYS:LIBSAI.REL). The LOADER searches these
02200 libraries, if necessary, after searching all the others except the
02300 automatic F4 search.
02400 ⊗
02500
02600 ;; #KS# LOADVR SWITCH
02700 IFN (LOADVR-=54), <
02800 LODBLK (LIBREQ,16,LBTAB,,=18)
02900 >
03000 IFE (LOADVR-=54), <
03100 LODBLK (LIBREQ,17,LBTAB,,=18)
03200 >
03300 ;; #KS#
03400
03500
00100 COMMENT ⊗ Ending Code, Symbols -- END Block
00200
00300 STAROT ETC. -- ENDING STUFF.
00400 These include some constant ending code, some extra standard
00500 symbols, the starting address block, if there is one, and so on.
00600 It's too messy to use the LODBLK macro on, so here it is in
00700 all its glory--
00800 ⊗
00900 EBLEN←←. ;COLLECT LENGTH.
01000
01100 ;If this is a Main Program, a starting address block is issued
01200 ; (via the GBOUT descriptor EBDSC); else EBDSC1 is used to issue
01300 ; all but the starting address block. Starting address is always
01400 ; relative 0 (addr of the BEGOUT code--see above)
01500 ?STAROT: XWD 7,1 ;STARTING ADDR BLOCK -- 1 DATA WORD
01600 XWD 200000,0 ;RELOCATE ADDRESS (RH)
01700 ↑STRDDR:0 ;STARTING ADDRESS ALWAYS REL 0
01800
01900 ; If Main Program, global requests must be issued to fill in
02000 ; the RPGSW and SAILOR blanks in the BEGOUT block (above)
02100 XWD 2,4 ;SYMBOL BLOCK
02200 XWD 42104,210421 ;EVERY OTHER WORD.
02300 ↑CONSYM:RADIX50 60,SAILOR;JSR REQUEST.
02400 2 ;JSR IS IN LOC 2
02500 RADIX50 60,RPGSW;FOR SETOM RPGSW BUSINESS
02600 1 ;SETOM IS IN 1
02700
02800 ; This part is always issued -- standard symbol names, end block
02900 NOSTAR: XWD 2,STRCT-NOSTAR-2;SYMBOLS
03000 XWD 40000,0;RELOCATE ONLY S.
03100 RADIX50 10,S. ;FIRST EXECUTABLE LOC IN PROG
03200 0 ;ALWAYS 0
03300 RADIX50 10,P ;SYSTEM PDP ADDR
03400 RP ;USUALLY 17
03500 RADIX50 10,SP ;STRING PDP ADDR
03600 RSP ;USUALLY 16
03700 RADIX50 10,ARERR;UUO FOR ARRAY INDEX OV/UNDERFLOW
03800 ARERR ;THE UUO OPCODE
03900 RADIX50 10,FLOAT;UUO FOR INTEGER to REAL
04000 FLOAT
04100 RADIX50 10,FIX ;UUO FOR REAL to INTEGER
04200 FIX
04300 RADIX50 10,SNGL ;UUO FOR LONG REAL to REAL
04400 SNGL
04500 STRCT: ;END OF EXTRA SYMBOLS
04600
04700 ; END BLOCK
04800 NOREN <
04900 XWD 5,1 ;END BLOCK.
05000 XWD 200000,0 ;RELOCATE PROGRAM BREAK WORD
05100 ↑↑PRGBRK: 0 ;PROGRAM BREAK-- FIRST NON-USED ADDR
05200 >;NOREN
05300 REN <
05400 XWD 5,2 ;TWO PROGRAM BREAKS
05500 XWD 240000,0 ;RELOCATE PROGRAM BREAK WORD
05600 ↑↑PRGBRK: 0 ;HIGH-SEG PROGRAM BREAK
05700 0 ;LOW-SEG PROGRAM BREAK
05800 >;REN
05900
06000 EBLEN←← .-EBLEN ;LENGTH OF ENTIRE OUTPUT RITUAL
06100
06200 ↑EBDSC: XWD EBLEN,STAROT ;IF MAIN PROGRAM
06300 ↑EBDSC1:XWD EBLEN+STAROT-NOSTAR,NOSTAR ;IF NOT
06400 ENDDATA
06500
00100 COMMENT ⊗ RELINI -- Loader Block Initialization⊗
00200
00300 DSCR RELINI
00400 CAL PUSHJ FROM GENINI
00500 DES SETS UP ALL REL-FILE OUTPUT STUFF BEFORE EACH COMPILATION
00600 ⊗
00700
00800 ↑↑RELINI:
00900 HLLZS BINTAB
01000 HLLZS FXTAB
01100 SETOM FXTAB+1 ;ALL RELOCATABLE
01200 HLLZS SMTAB ;CLEARS OUTPUT BUFFER COUNTS
01300 HLLZS PRGTAB ;PROGRAM AND LIBRARY REQUEST BLOCKS
01400 HLLZS LBTAB
01500 MOVE A,[XWD SPCPC,SPCPC+1] ;CLEAR SPACE ALLOCATION BLOCK
01600 SETZM SPCPC
01700 BLT A,SPCEND ;SIZE ALLOCATION BLOCK.
01800 HRRI TEMP,SPCSIZ
01900 HRRM TEMP,SPCTBL
02000 POPJ P, ;RETURN TO GENINI
02100
00100 COMMENT ⊗ GBOUT Routine⊗
00200
00300 ↑GBOUT:
00400 PUSH P,A ;SAVE A
00500 PUSH P,B ;SAVE ADDRESS OF BUFFER
00600 HLRZ A,B ;GET COUNT IF NONSTANDARD
00700
00800 TLO FF,IREGCT ;SET NON-STANDARD COUNT BIT
00900 HRLI B,(<POINT 36,0>) ;FOR PICKING UP WORDS
01000 MOVEM B,OUTADR ;SAVE TABLE ADDRESS
01100 JUMPN A,GBOUTA ;NOT STANDARD (FROM TABLE) COUNT
01200 HRRZ A,(B) ;GET COUNT FROM BLOCK
01300 ;;#TR# BE MORE HONEST ON COMPUTING THIS
01400 ; ADDI A,2 ; +2 FOR BLOCK TYPE & RELOC
01500 ADDI A,=35 ; CNT ← CNT+1+FLOOR((A+17)/18)
01600 IDIVI A,=18
01700 HRRZ B,@OUTADR ;WORD CNT AGAIN
01800 ADD A,B ; CORRECT VALUE (I HOPE)
01900
02000 TLZ FF,IREGCT ;RESET NON-STANDARD COUNT BIT
02100
02200 ; OUTPUT ROUTINE
02300
02400 GBOUTA: TLNN FF,BINARY ;IS THERE A BINARY FILE?
02500 JRST OUTDUN ;NO, DON'T WRITE
02600 CAIGE A,3 ;IS THERE ANYTHING TO WRITE?
02700 JRST OUTDUN ;NO, DON'T DO IT
02800
02900 NOTENX <
03000 BQN: SOSLE BINCNT ;FULL?
03100 JRST OKOUT ;NO
03200 OUTPUT BIN,0 ;EMPTY BUFFER, ON TO NEXT
03300 TSTERR BIN ;ERRORS?
03400 ERR <OUTPUT ERROR ON BINARY FILE>
03500
03600 OKOUT: ILDB B,OUTADR ;BLOCK WORD
03700 IDPB B,BINPNT
03800 SOJG A,BQN ;WRITE THEM ALL
03900 >;NOTENX
04000 TENX <
04100 PUSH P,C
04200 MOVNI C,(A)
04300 MOVE B,OUTADR
04400 SKIPL A,BINJFN ;JUST IN CASE IT'S -1 (DUMMY)
04500 JSYS SOUT
04600 MOVEM B,OUTADR ;UPDATE OUTADR
04700 POP P,C
04800 >;TENX
04900
05000 OUTDUN: POP P,B ;GET BUFFER ADDR BACK
05100 TLZN FF,IREGCT ;DON-'T CLEAR IF NON-STANDARD COUNT
05200 HLLZS (B) ;CLEAR COUNT
05300 POP P,A ;RESTORE A
05400 POPJ P,
05500
00100 COMMENT ⊗ CODOUT Routine -- Output Code or Data⊗
00200
00300 DSCR CODOUT -- WRITE DATA (ALSO CODREL)
00400
00500 PAR WORD IN "A"
00600 relocatable if RELOC in in "FF"
00700 (if rh of A is zero, then never RELOC. If you want to
00800 TO BYPASS THIS TEST, CALL "CODREL").
00900
01000 RES Writes word, increments program counter (PCNT)
01100
01200 SID Uses A,B,C -- Saves all
01300 ⊗;
01400
01500 ↑CODOUT:
01600 SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
01700 POPJ P, ; EXPR!TYPE)
01800 PUSH P,A
01900 PUSH P,B
02000
02100 SKIPE FRSTSW ;HAVE WE DONE THIS BEFORE
02200 JRST COD1 ; YES, DON'T DO AGAIN
02300 SETOM FRSTSW
02400 PUSH P,LPSA ;AND SOME OTHERS
02500 MOVEI LPSA,IPROC ;GET PROGRAM NAME.
02600 PUSHJ P,RAD50 ;IN RADIX50
02700 TLZ A,740000 ;RADIX50 0,NAME
02800 MOVEM A,PRGTTL
02900 MOVE B,BEGCNT
03000 PUSHJ P,GBOUT ;WRITE NAME BLOCK
03100 REN <
03200 MOVEI A,0
03300 SKIPN HISW ;TWO-SEGMENT PROGRAM?
03400 JRST JUST1 ;NO
03500 MOVE B,HBLK2 ;YES, WRITE HISEG (TYPE 3) BLOCK
03600 PUSHJ P,GBOUT
03700 MOVEI A,400000 ;BEGINNING PC
03800 JUST1:
03900 MOVEM A,BEGPC ;IN WHICH SEGMENT
04000 >;REN
04100 MOVE B,BEGCT2 ;CALL TO INIT & LINKAGE
04200 PUSHJ P,GBOUT
04300 COD2: POP P,LPSA
04400 MOVE A,-1(P) ;RESTORE A.
04500
04600 COD1: TRNN A,-1 ;ZERO ADDRESS?
04700 TLZ FF,RELOC ;YES, NO RELOC
04800 JRST CDRL1
04900 ↑CODREL:
05000 PUSH P,A ;ENTER HERE TO BYPASS ZERO TEST
05100 PUSH P,B
05200 CDRL1:
05300 HRRZ B,BINTAB ;GET COUNT
05400 JUMPN B,BAQ ;FIRST WORD OF BLOCK?
05500
05600 AOS BINTAB ;YES, SET UP BLOCK
05700 MOVE B,PCNT ;SET LOCATION WORD
05800 MOVEM B,BINTAB+2 ;INTO 3D WORD OF BLOCK
05900 SETZM BINTAB+1 ;CLEAR RELOCATION BITS
06000 MOVE B,[POINT 2,BINTAB+1] ;BYTE POINTER FOR RELOC BITS
06100 MOVEM B,CODPNT ;TO RIGHT PLACE
06200 MOVEI B,1 ;RELOCATE THE LOC COUNTER WORD
06300 IDPB B,CODPNT
06400
06500 BAQ: AOS B,BINTAB ;INCREMENT COUNT
06600 HRRZS B ;AND MOVE TO B
06700 MOVEM A,BINTAB+1(B) ;DEPOSIT WORD
06800 MOVEM A,LSTWRD ;SAVE LAST WORD OUTPUT
06900 LDB A,[POINT 1,FF,RLCPOS] ;RELOC?
07000 SKIPE LHRELC ;RELOC LEFT HALF?
07100 ADDI A,2 ;SAY SO
07200 MOVEM A,LSTRLC ;AND LAST RELOCATION BIT.
07300 IDPB A,CODPNT ;SET RELOC BITS
07400
07500 AOS PCNT ;INCREMENT COUNT
07600
07700 CAIGE B,22 ;FULL?
07800 JRST CDRET ;NO, RETURN
07900
08000 MOVEI B,BINTAB ;INDICATE STANDARD COUNT AND WHICH TABLE
08100 PUSHJ P,GBOUT ;WRITE BLOCK
08200 ; JRST CDRET
08300
08400 CDRET: POP P,B
08500 POP P,A
08600 POPJ P,
08700
08800 ↑CODLRL: ;RELOCATE LEFT HALF -- FF SAYS ABOUT RIGHT HALF
08900 TLNE A,-1 ;NEVER RELOCATE 0
09000 SETOM LHRELC ;SET FLAG
09100 PUSHJ P,CODOUT
09200 SETZM LHRELC
09300 POPJ P,
09400
09500 ZERODATA( DISPLAY STUFF)
09600 LHRELC: 0
09700 ENDDATA
09800
09900
10000
00100
00200 DSCR FRBT
00300 DES Force out current binary (BINTAB) code block,
00400 even if it's not full yet. This is done whenever
00500 symbols or fixups which might refer to this code
00600 are put out, so that there is something to fixup
00700 or refer to symbolically. It is also called from DONES.
00800 SID Saves all ACS
00900 ⊗
01000
01100 ↑FRBT: PUSH P,B
01200 MOVEI B,BINTAB
01300 PUSHJ P,GBOUT ;CLEAR BINARY BUFFER
01400 POP P,B
01500 POPJ P,
01600
01700
00100 COMMENT ⊗ FBOUT, etc. -- Output Fixups⊗
00200
00300 DSCR FBOUT,FIXOUT,FBOSWP
00400 DES Put word of fixup information into output file.
00500 PAR B contains fixup specification:
00600 lh -- PCNT of actual location of entity
00700 rh -- PCNT of last word in fixup chain.
00800 FBOSWP takes the above B value, swapped.
00900 RES This word is written into the FXTAB fixup Loader
01000 block via GBOUT (when there are enough).
01100 FBOUT always assumes both halves reloatable
01200 FIXOUT always assumes the actual (lh) address is not
01300 relocatable
01400 FBOSWP is included for convenience
01500 SID Saves all ACs
01600 ⊗;
01700
01800 ↑FXOSW2: MOVSS B
01900 PUSHJ P,FIXOUT
02000 MOVSS B
02100 POPJ P,
02200 ↑FBOSW2: MOVSS B
02300 PUSHJ P,FBOUT
02400 MOVSS B
02500 POPJ P,
02600
02700 ↑FBOSWP: MOVSS B
02800 ↑FBOUT: SKIPE NOEMIT ; GET OUT IF NO CODE IS TO BE EMITTED (I.E.
02900 POPJ P, ; EXPR!TYPE)
03000 TLNN B,-1 ;IS LEFT HALF ZERO?
03100 ERR <DRYROT -- FBOUT>,1
03200 TLOA FF,FFTEMP ;USE RELOCATION IN FIXUP SIDE
03300 ↑FIXOUT:
03400 TLZ FF,FFTEMP ;DO NOT RELOCATE FIXUP PART
03500 PUSH P,B
03600 PUSH P,A ;SAVE A
03700 HRRZ A,FXTAB
03800 JUMPN A,FAQ ;FIRST WORD OF BLOCK?
03900 MOVE A,[POINT 2,FXTAB+1] ;YES, RESET RELOCATION BIT POINTER
04000 MOVEM A,FXPNT ; (SEE CODOUT FOR SIMILARITIES)
04100 FAQ:
04200 AOS A,FXTAB ;INCREMENT AND FETCH COUNT
04300 HRRZS A
04400 MOVEM B,FXTAB+1(A) ;DEPOSIT WORD
04500 MOVEI B,3 ;ASSUME BOTH HALVES RELOC
04600 TLNN FF,FFTEMP ;TEST ASSUMPTION
04700 MOVEI B,2 ; WRONG
04800 IDPB B,FXPNT ;INSERT RELOCATION BITS
04900
05000 CAIGE A,22 ;FULL?
05100 JRST FXRET ;NO, RETURN
05200
05300 PUSHJ P,FRBT ;FORCE OUT ANY BINARY
05400 ;(BECAUSE FIXUPS HAVE TO COME AFTER)
05500
05600 MOVEI B,FXTAB
05700 PUSHJ P,GBOUT ;WRITE BLOCK
05800
05900 FXRET: POP P,A
06000 POP P,B
06100 POPJ P,
06200
06300
06400
00100 COMMENT ⊗ SCOUT, etc. -- Output Symbols⊗
00200
00300 DSCR SOUT,SCOUT,SHOUT,SCOUT0
00400 DES Output symbols in RADIX50 -- many ways exist for
00500 obtaining symbols for output, thus the proliferation.
00600
00700 PAR
00800 SOUT: LPSA -- Semantics ptr. $PNAME and $ADR are used to
00900 obtain the symbol and address.
01000 SHOUT: LPSA -- descriptor of the form:
01100 bits 0-5 DDT symbol type
01200 6-17 #characters
01300 18-35 address of string in ASCII (assumed justified)
01400 B -- address for symbol
01500 SCOUT: A -- RADIX50 for symbol
01600 B -- address for symbol
01700 SCOUT0: SAME AS SCOUT, BUT MAKES SYMBOL NON-RELOCATABLE.
01800
01900 SID A, TEMP, may be different on exit
02000 ⊗;
02100
02200 ↑SHOUT: PUSHJ P,RAD52
02300 JRST SCOUT ;MAKE RADIX50 FROM DESCRIPTOR
02400
02500 ↑SCOUT0: PUSH P,B ;NON-RELOCATED SYMBOL
02600 MOVEI TEMP,0
02700 JRST SASS
02800
02900
03000 ↑SOUT: PUSHJ P,RAD50 ;GET RADIX50 FOR SYMBOL
03100 PUSH P,B ;SAVE IT
03200 ;;# # RHT 3-19-73 MAKE RECSV SYMBOLS GO OUT UNRELOC
03300 HRRZ B,$ADR(LPSA) ;GET ADDRESS
03400 MOVE TEMP,$SBITS(LPSA);DOES THIS SYMBOL USE THE STACK?
03500 TRNN TEMP,DLFLDM ;
03600 JRST SOUT.0 ;NO
03700 CAIGE B,20 ;HALF KILL??
03800 TLO A,400000 ;YES
03900 MOVEI TEMP,0 ;
04000 JRST SASS
04100 ;;# # RHT
04200
04300 ;;# # RHT -- 7-13-73 EXTRA KLUGE TO USE THE RAD5$ SYMBOL FOR
04400 ;; SPECIAL BILTIN RUNTIMES
04500 SOUT.0: SETCM TEMP,$TBITS(LPSA)
04600 TLNE TEMP,FNYNAM+OWN+EXTRNL
04700 JRST SOUT.1 ;REGULAR
04800 SKIPA A,RAD5$ ;PREMIUM
04900 ;;# #
05000 ↑SCOUT: PUSH P,B ;SAVE
05100 SOUT.1: MOVEI TEMP,1 ;RELOCATION BIT.
05200 SASS: PUSH P,C
05300 HRRZ C,SMTAB
05400 JUMPN C,SAQ
05500 MOVE C,[POINT 4,SMTAB+1]
05600 MOVEM C,SMPNT
05700 SAQ:
05800 CAMN A,LSTRAD ;RADIX50 FOR LAST BLOCK NAME.
05900 JRST SYMRET ;DO NOT PUT IT OUT.
06000 AOS C,SMTAB ;BINARY DOES NOT HAVE TO BE
06100 HRRZS B ;FORCED OUT
06200 MOVEM A,SMTAB+1(C)
06300 MOVEM B,SMTAB+2(C)
06400 AOS C,SMTAB
06500 HRRZS C
06600 LDB B,[POINT 4,A,3] ;DON'T RELOCATE BLOCK LEVELS
06700 CAIN B,3 ;BLOCK TYPE 14
06800 MOVEI TEMP,0
06900 IDPB TEMP,SMPNT
07000 CAIGE C,22
07100 JRST SYMRET
07200
07300 PUSHJ P,FRBT ;MAKE BINARY GO FIRST
07400 MOVEI B,SMTAB
07500 PUSHJ P,GBOUT
07600
07700 SYMRET: POP P,C
07800 POP P,B
07900 POPJ P,
08000
00100 COMMENT ⊗ LNKOUT -- Output Linkage Block⊗
00200
00300 DSCR LNKOUT --
00400 DES Put out a (type 12) Link block via GBOUT. These blocks
00500 allow chains of addresses to be created through separate
00600 .REL files. STRINGC uses LINK 1 to find all its strings.
00700 Other uses are for SETS, STRINGC routine names, and the
00800 space allocation block.
00900 PAR B -- link number
01000 PCNT -- decremented by one; that is address for LINK rqst.
01100 ⊗
01200
01300 ↑LNKOUT: MOVEM B,LNKNM ;SAVE LINK NUMBER
01400 PUSHJ P,FRBT ;NOTE DOES NOT SAVE ACS
01500 HRRZ TEMP,PCNT
01600 SUBI TEMP,1 ;LAST WORD OUTPUT WILL HOLD LINK
01700 HRRZM TEMP,SLNKWD ;PLACE IN ADDR WORD OF LINK BLOCK TEMPLATE
01800 MOVE B,SDSCRP ;DESCRIPTOR OF LINK BLOCK [COUNT,ADDR OF TEMPLATE]
01900 PUSHJ P,GBOUT
02000 POPJ P, ;RETURN AFTER WRITING BLOCK
02100
00100 COMMENT ⊗ PRGOUT, FILSCN -- Output Request Blocks, Scan for Source!file Rqst⊗
00200
00300 DSCR FILSCN -- CONVERT ASCII FILE-STRING TO SIXBIT
00400 PAR PNAME, PNAME+1 describe a String representing the file
00500 name.
00600 RES A, C, D return DEVICE, FILENAME, and PPN in SIXBIT
00700 DES Converts String to SIXBIT via FILNAM routine (approp-
00800 riately informed) in Command Scanner (SAIL). Extension
00900 not returned, because there's currenlty no need.
01000 SID Nothing much saved
01100 SEE FILNAM, PRGOUT, RQSET, SRCSWT
01200 ⊗
01300 NOTENX <
01400 ↑↑FILSCN: SETOM TYICORE ;TYI IN COMND WILL GET CHARS FRM STRNG
01500 PUSH P,DEVICE ;SAVE FILE DATA
01600 PUSH P,EXTEN
01700 PUSH P,SAVTYI
01800 PUSH P,EOL
01900 SETZM SAVTYI ;NO SCAN-AHEAD
02000 MOVSI TEMP,(<SIXBIT /DSK/>) ;DEFAULT DEVICE
02100 MOVEM TEMP,DEVICE
02200 PUSHJ P,FILNAM ;GET SIXBITS IN NAME, EXTEN, ETC.
02300 MOVE A,DEVICE ;LOAD RESULTS
02400 MOVE C,NAME
02500 MOVE D,PPN
02600 POP P,EOL
02700 POP P,SAVTYI
02800 POP P,EXTEN
02900 POP P,DEVICE ;RESTORE OLD VALUES
03000 POPJ P,
03100 >;NOTENX
03200
03300 TENX <
03400 TFLSCN:
03500 BEGIN TFLSCN
03600
03700 CTRLV←←"V"-100 ;TENEX QUOTING CHARACTER
03800 FIND←←D
03900
04000 SETZM FIND
04100 PUSH SP,PNAME ;ORIGINAL NAME -- COPY ONTO STACK
04200 PUSH SP,PNAME+1
04300 PUSH SP,[0] ;DEVICE TEMPORARY
04400 PUSH SP,[0]
04500 PUSH SP,[0] ;DIR TEMPORARY
04600 PUSH SP,[0]
04700 PUSH SP,[0] ;NAM TEMPORARY
04800 PUSH SP,[0]
04900
05000 DEFINE ORIG <-7(SP)>
05100 DEFINE ORIG1 <-6(SP)>
05200 DEFINE DEV <-5(SP)>
05300 DEFINE DEV1 <-4(SP)>
05400 DEFINE DIR <-3(SP)>
05500 DEFINE DIR1 <-2(SP)>
05600 DEFINE NAM <-1(SP)>
05700 DEFINE NAM1 <0(SP)>
05800
05900 ;SIMPLE SINCE NAME IS AT THE TOP OF SP
06000 DEFINE CATNAM (X) <
06100 PUSH P,X
06200 PUSHJ P,CATCHR
06300 >
06400 DEFINE CATDIR (X) <
06500 PUSH P,X
06600 PUSH SP,DIR
06700 PUSH SP,DIR
06800 PUSHJ P,CATCHR
06900 POP SP,-4(SP)
07000 POP SP,-4(SP)
07100 >
07200
07300 DEFINE GCH <
07400 HRRZ A,ORIG
07500 JUMPE A,TENDUN
07600 ILDB C,ORIG1
07700 SOS ORIG
07800 >
07900
08000 TENX1: GCH
08100 CAIE C,CTRLV
08200 JRST NOQUOTE
08300 SKIPE FIND
08400 JRST QUODIR
08500 PUSHJ P,CATNA3
08600 GCH
08700 PUSHJ P,CATNA3 ;AND THE CHAR FOLLOWING THE CTRLV
08800 JRST TENX1
08900 QUODIR: PUSHJ P,CATDI3
09000 GCH
09100 PUSHJ P,CATDI3
09200 JRST TENX1 ;AND CONTINUE
09300
09400 NOQUOTE:
09500 CAIN C,":" ;COLON -- DEVICE
09600 JRST ISDEV ;ITS BEEN A DEVICE ALL ALONG!!
09700 CAIN C,","
09800 JRST TENX1 ;IGNORE COMMA
09900 CAIE C,40 ;SPACE
10000 CAIN C,11 ;OR TAB
10100 JRST TENX1
10200 CAIE C,"<" ;THESE START THE DIRECTORY NAME
10300 CAIN C,"["
10400 JRST STTDIR
10500 CAIE C,">" ;THESE FINISH THE DIR. NAME
10600 CAIN C,"]"
10700 JRST ENDDIR
10800 SKIPE FIND ;DOING DIRECTORY?
10900 JRST .+3 ;YES
11000 PUSHJ P,CATNA3
11100 JRST TENX1
11200 PUSHJ P,CATDI3
11300 JRST TENX1
11400
11500 STTDIR: SETOM FIND
11600 JRST TENX1
11700
11800 ENDDIR: SETZM FIND
11900 JRST TENX1
12000
12100 ;;#SK# 5-30-74 RLS DONT MESS UP DEVICE NAME IF PRESENT
12200 ISDEV:
12300 MOVE C,NAM ;THE "NAME" HAS REALLY BEEN A DEV
12400 MOVEM C,DEV
12500 MOVE C,NAM1
12600 MOVEM C,DEV1
12700
12800 SETZM NAM ;SO CLEAR THE NAME -- START OVER
12900 SETZM NAM1
13000 JRST TENX1
13100
13200 TENDUN:
13300 ;NOW STACK HAS ORIG,DEV,DIR,NAM
13400 GOTDIR:
13500 ;NOW FIND ONLY THE NAME -- IGNORE EXTENSION, VERSION, ETC.
13600 PUSH SP,[0] ;NEW TEMPORARY
13700 PUSH SP,[0]
13800 NAMLUP: HRRZ A,-3(SP)
13900 SOS -3(SP) ;DECREMENT
14000 JUMPE A,GOTDI1
14100 ILDB C,-2(SP)
14200 CAIE C,"." ;QUIT ON PERIOD
14300 CAIN C,";" ;OR SEMICOLON
14400 JRST GOTDI1
14500 PUSH P,C
14600 PUSHJ P,CATCHR
14700 JRST NAMLUP
14800 GOTDI1: POP SP,-2(SP) ;REMOVE TEMPORARY
14900 POP SP,-2(SP)
15000 HRRZ A,-1(SP) ;CHECK LENGTH OF NAME
15100 CAILE A,6
15200 ERR <Name too long for loader.>,1
15300 PUSHJ P,CVSIX ;GET SIXBIT FOR NAME
15400 MOVEM A,C ;INTO C
15500
15600 PUSHJ P,DIRPPN ;TRANSLATE DIRECTORY STRING TO PPN
15700 MOVEM A,D ;PLACE PPN IN D
15800
15900 HRRZ A,-1(SP) ;NOW DO THE DEVICE
16000 CAILE A,6
16100 ERR <Device name too long for loader.>,1
16200 PUSHJ P,CVSIX ;SIXBIT FOR DEVICE INTO A
16300 SKIPN A ;ANYTHING THERE?
16400 MOVE A,[SIXBIT/DSK/] ;ASSUME DEVICE DSK
16500 SUB SP,X22 ;CLEAR OFF COPY OF PNAME
16600 POPJ P,
16700
16800 ;CALL CAT MACROS WITH AC C AS THE ARG
16900 CATNA3: CATNAM C
17000 POPJ P,
17100
17200 CATDI3: CATDIR C
17300 POPJ P,
17400
17500
17600 DIRPPN:
17700 ; DIRPPN -- CONVERT ASCII DIRECTORY NAME TO PPN (NEEDED FOR THE LOADER)
17800 ; PAR STRING DEVICE-NAME, DIRECTORY-NAME (ON SP STACK)
17900 ; (DEVICE-NAME IS NOT REMOVED)
18000 ; RES A: PPN
18100 ; SID SAME AS SIXBIT (EVERYTHING BUT A)
18200 HRRZ A,-1(SP) ;IF DIRECTORY NAME LENGTH = 0
18300 JUMPE A,DIRP.X ; RETURN(0)-ASSUME CONNECTED DIR
18400 IFN SIXSW,< ;USE SIXBIT(DIRNAME) AS PPN
18500 CAILE A,6 ;VERIFY THAT NAME FITS IN SIXBIT
18600 ERR <DIRECTORY TOO LONG FOR LOADER.>,1
18700 JRST CVSIX ; RETURN( CVSIX(ARG) )
18800 >;IFN SIXSW
18900 IFE SIXSW,< ;NOT SIXBIT, MORE FINAGGLING NECESSARY
19000 ; Modifications made to support TOPS20 v. 3
19100 ; Robert Smith
19200 ; Rutgers University
19300 ; March 12, 1978
19400 ; DEC has blown it! They removed the STDIR jsys, and
19500 ;changed the conventions in the emulator about directory-to-ppn
19600 ;conversion. However, there is a new JSYS, STPPN, that will
19700 ;now suffice.
19800 ; Algorithm for the following code:
19900 ;IF STDEV("NIL") fails, THEN
20000 ; BEGIN "assume TOPS20"
20100 ; AC[D] ← STPPN("<" & directory " ">" & 0);
20200 ; END ELSE
20300 ; BEGIN "assume TENEX"
20400 ; rh of AC[D] ← STDIR(directory & 0);
20500 ; END;
20600 BEGIN DIRNAME
20650 EXTERN CHRCAT
20700 PUSH P,B ;SAVE B
20800 HRROI A,[ASCIZ/NIL/]
20900 JSYS STDEV ;IS IT TENEX?
21000 JRST TOPS20 ;ERROR RETURN--MEANS TOPS20
21100 PUSH P,[0] ;MAKE STRING ASCIZ BY APPENDING
21200 PUSHJ P,CATCHR ;NULL BYTE TO END OF STRING
21300 MOVE B,(SP) ;BP TO ASCIZ
21400 MOVEI A,1 ;POSITIVE -- NO RECOGNIZE
21500 JSYS STDIR ;TWO ERROR RETURNS (+1 AND +2)
21600 JFCL ;HANDLE IDENTICALLY
21700 JRST [ERR <This directory does not exist on this system.>,1
21800 SETZ A, ;RESULT 0(CONNECTED DIRECTORY)
21900 JRST CLNUP ;AND CLEANUP
22000 ]
22100 HRLI A,4 ;4,,DIRNO
22200 JRST CLNUP ;CLEANUP STACK AND RETURN
22300
22400 ;HERE WITH TOPS20
22500 ;FIRST BUILD A STRUCTURE NAME
22600 ;SP STACK:
22700 ; DEVICE-NAME
22800 ; DIRECTORY-NAME
22900 TOPS20: ;
23000 ;FIRST SURROUND DIRECTORY-NAME WITH "<>" PAIR
23100 PUSH P,[74] ;LEFT BROKET
23200 PUSHJ P,CHRCAT
23300 PUSH P,[76] ;RIGHT BROKET
23400 PUSHJ P,CATCHR
23500 ;NOW SEE IF THERE IS A DEVICE NAME
23600 HRRZ B,-3(SP) ;IF NOT LENGTH(DEVICE-NAME)
23700 JUMPE B,NODEVN ;THEN GOTO NODEVN
23800
23900 PUSH SP,-3(SP) ;DEVICE-NAME
24000 PUSH SP,-3(SP)
24100 PUSH P,[":"] ;WITH A COLON
24200 PUSHJ P,CATCHR
24300 PUSH SP,-3(SP) ;DIRECTORY-NAME
24400 PUSH SP,-3(SP)
24500 PUSHJ P,CAT ;
24600 POP SP,-2(SP) ;CLOBBERS DIRECTORY-NAME ON
24700 POP SP,-2(SP) ;STACK
24800
24900 NODEVN:
25000 PUSH P,[0] ;PREPARE FOR STPPN
25100 PUSHJ P,CATCHR ;AND PUT A NULL ON THE END ;
25200 MOVE A,0(SP) ;STRING POINTER
25300 OPDEF STPPN [104000000556]
25400 STPPN ;PPN IN REG A
25450 MOVEM B,A ;FOR RETURN
25500 CLNUP: POP P,B ;RESTORE B
25600 BEND DIRNAME
25700 >;IFE SIXSW
25800 DIRP.X: SUB SP,X22 ;REMOVE ARGUMENT FROM SP
25900 POPJ P, ;AND LEAVE
26000
26100 BEND TFLSCN
26200 >;TENX
00100
00200
00300 DSCR PRGOUT -- OUTPUT PROGRAM AND LIBRARY REQUEST BLOCKS
00400 DES Output (via GBOUT) Program and Libraray REQUEST BLOCKS.
00500 PAR B ptr to PRGTAB or LBTAB (program or library request)
00600 PNAME, PNAME+1 as in FILSCN
00700 Defaults as in FILSCN; DEVICE, FILE and PPN will be passed
00800 to the loader.
00900 RES FILSCN is called to make SIXBIT representations of DEVICE,
01000 FILE, and PPN; these are placed in the output block.
01100 SID Saves the world
01200 ⊗;
01300
01400 ↑↑PRGOUT:
01500 NOTENX<
01600 MOVE USER,GOGTAB ;SAVE ACS IN USER TABLE AREA
01700 HRRZI TEMP,RACS(USER)
01800 BLT TEMP,SBITS2+RACS(USER) ;FILNAME USES MANY ACS
01900 PUSHJ P,FILSCN ;GET SIXBITS IN A,C,D
02000 MOVE B,RACS+2(USER) ;GET TABLE ADDRESS BACK
02100 MOVEI TEMP,3 ;PREPARE TO COUNT UP BLOCK COUNT
02200 ADDB TEMP,(B)
02300 ADDI TEMP,(B) ;ptr to AREAS TO BE FILLED
02400 MOVEM C,-1(TEMP) ;STORE NAME
02500 ;;=I10= SFD PATCH - BE SURE WE HAVE A REAL PPN
02600 SFDS<
02700 JUMPE D,.+3 ;ZERO PPN IS OK
02800 TLNN D,777777 ;SO IS A REAL PPN
02900 ;;JOHN - POSSIBLE YOU WANT TO ISSUE AN ERROR MESSAGE HERE INSTEAD
03000 MOVE D,2(D) ;IF PATH PTR, USE PPN FROM PATH
03100 > ;SFDS
03200 MOVEM D,00(TEMP) ;STORE PPN
03300 MOVEM A,01(TEMP) ;STORE DEVICE
03400 TYMSHR<
03500 JUMPE D,PRGOU2 ;IF NO PPN
03600 TLNN D,-1 ;OR IF REAL PPN
03700 CAME A,[SIXBIT /DSK/] ;OR NOT DISK
03800 JRST PRGOU2
03900 MOVE C,AVLSRC
04000 JFFO C,.+2
04100 JRST PRGOU2
04200 CAILE D,17
04300 JRST PRGOU2 ;FIND CHANNEL
04400 PUSH P,B
04500 MOVSI A,(<RELEASE>)
04600 DPB D,[POINT 4,A,12]
04700 PUSH P,A
04800 MOVE A,[LOOKUP A]
04900 DPB D,[POINT 4,A,12]
05000 PUSH P,A
05100 MOVE A,[OPEN B]
05200 DPB D,[POINT 4,A,12]
05300 MOVEI B,16
05400 MOVSI C,'DSK'
05500 MOVEI D,0
05600 XCT A
05700 JRST PRGOU3
05800 MOVEI A,3 ;NOW LOOKUP
05900 MOVE B,(TEMP)
06000 MOVE C,-1(TEMP)
06100 MOVEI D,0
06200 XCT (P)
06300 JFCL
06400 MOVEM B,(TEMP) ;SAVE PPN
06500 PRGOU3: POP P,A
06600 POP P,A ;THE RELEASE
06700 XCT A
06800 POP P,B
06900 PRGOU2:>
07000
00100 >;NOTENX
00200 TENX<
00300 PUSH P,A ;MUST PUSH SINCE TFLSCN CALLS RUNTIMES
00400 PUSH P,C
00500 PUSH P,D
00600 EXCH SP,STPSAV ;GET A STRING STACK
00700 PUSHJ P,TFLSCN ;DOES NOT MODIFY B
00800 EXCH SP,STPSAV ;RESTORE IT
00900 MOVEI TEMP,3
01000 ADDB TEMP,(B)
01100 ADDI TEMP,(B) ;ptr to AREAS to be filled
01200 MOVEM C,-1(TEMP) ;STORE NAME
01300 MOVEM D,00(TEMP) ;STORE PPN
01400 MOVEM A,01(TEMP) ;STORE DEVICE
01500 POP P,D
01600 POP P,C
01700 POP P,A ;RESTORE
01800 PUSH P,TEMP
01900 MOVE USER,GOGTAB ;SAVE FOR KROCK BELOW
02000 HRRZI TEMP,RACS(USER)
02100 BLT TEMP,SBITS2+RACS(USER)
02200 POP P,TEMP
02300 >;TENX
02400 HRRZS TEMP
02500 CAIL TEMP,22(B) ;BLOCK FULL?
02600 PUSHJ P,GBOUT ;YES, PUT IT OUT
02700 HRLZI TEMP,RACS(USER)
02800 BLT TEMP,SBITS2
02900 POPJ P, ;TRA 0,4?
03000
03100 SUBTTL Generator Miscellaneous.
03200
00100 COMMENT ⊗ RAD50, RAD52 -- Radix-50 Functions for Scout Routines⊗
00200
00300 DSCR RAD50,RAD52 -- create a RADIX50 symbol
00400 PAR RAD50 -- LPSA pntr to block head -- string is in $PNAME, etc.
00500 RAD52 -- LPSA(lh) is count, LPSA (rh) is address of string,
00600 assumed aligned.
00700 RES RADIX50 for symbol in A
00800 SID Results in A, all other ACS saved (except TEMP)
00900 ⊗;
01000
01100 ↑RAD50:
01200 EXCH SP,STPSAV
01300 MOVSS POVTAB+6 ;ENABLE FOR STRING PDL OV
01400 PUSH SP,$PNAME(LPSA) ;COLLECT POINTERS IN COMMON SPOT
01500 PUSH SP,$PNAME+1(LPSA)
01600 HRRZS -1(SP) ;CLEAR STRNO, SAVE COUNT
01700 MOVE A,$TBITS(LPSA) ;CONTROLS MODE BITS IN RAD50 SYMBOL
01800 MOVEI TEMP,10/4 ;ASSUME LOCAL
01900 TLNE A,INTRNL ;INTERNAL IS TYPE 4
02000 MOVEI TEMP,4/4
02100 TLNE A,EXTRNL
02200 MOVEI TEMP,60/4 ;EXTERNAL IS TYPE 60
02300 MOVEI A,0 ;INITIALIZE A
02400 JRST RAD5
02500
02600
02700 ↑RAD52:
02800 LDB TEMP,[POINT 12,LPSA,17] ;COUNT
02900 EXCH SP,STPSAV
03000 MOVSS POVTAB+6 ;ENABLE FOR STRING PDLOV
03100 PUSH SP,TEMP
03200 PUSH SP,LPSA ;MAKE IT LOOK LIKE STRING
03300 HRRI TEMP,(<POINT 7,0>) ; DESCRIPTOR
03400 HRLM TEMP,(SP)
03500 MOVEI A,0
03600 LDB TEMP,[POINT 4,LPSA,3]
03700
03800 RAD5: PUSH P,TEMP
03900 PUSH P,B ;SAVE IT
04000 MOVEI TEMP,6
04100
04200 R50LUP: SOSGE -1(SP) ;QUIT IF NO MORE STRING
04300 JRST R5OUT
04400 ILDB B,(SP) ;CHARACTER
04500 CAIN B," " ;IGNORE BLANKS ABSOLUTELY!
04600 JRST R50LUP ; THIS RUNS ALL THE CHARACTERS TOGETHER
04700 CAIL B,"a"
04800 CAILE B,"z"
04900 JRST .+2
05000 SUBI B,40 ;CONVERT TO UPPER CASE
05100 CAIE B,30 ;UNDERLINE:THESE CHARS HAVE TO BE CREATED INDIVIDUALLY
05200 CAIN B,"."
05300 MOVEI B,66+45 ;RAD50 CHAR FOR "." + 66 TO BE SUBTRACTED
05400 ;;#GQ# DCS 2-8-72 (1-1) ! SAME AS UNDERLINE
05500 CAIN B,"!" ;! SAME AS UNDERLINE
05600 MOVEI B,66+45 ;"."
05700 ;;#GQ# (1)
05800 CAIN B,"$"
05900 MOVEI B,66+46
06000 CAIN B,"%"
06100 MOVEI B,66+47
06200 SUBI B,66 ;OK IF A LETTER
06300 CAIG B,12 ;<12 IF A NUMBER
06400 ADDI B,7 ; THIS MAKES IT RIGHT
06500 IMULI A,50 ;THAT'S THE NUMBER ALL RIGHT
06600 ADD A,B ;COLLECT RADIX50
06700 SOJN TEMP,R50LUP ;QUIT AT 6
06800
06900 R5OUT: MOVEM A,RAD5. ;NOW CREATE SAME SYMBOL WITH
07000 JUMPLE TEMP,MORFIV ;MORE THAN FIVE CHARS?
07100 IMULI A,50 ;MAKE IT "SYMB".
07200 SKIPA
07300 MORFIV: SUB A,B ;"." IN PLACE OF THE LAST
07400 POP P,B ;RESTORE B
07500 POP P,TEMP ;TYPE BITS.
07600 DPB TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
07700 ADDI A,46 ;$
07800 MOVEM A,RAD5$
07900 ADDI A,1 ;%
08000 MOVEM A,RAD5% ;
08100 SUBI A,2 ;"."
08200 EXCH A,RAD5. ; AND STORE IT IN RAD5. FOR STRINGS
08300 DPB TEMP,[POINT 4,A,3] ;TYPE BITS TO RADIX 50
08400 SUB SP,X22
08500 EXCH SP,STPSAV ;RESTORE REGS
08600 MOVSS POVTAB+6 ;RE-ENABLE FOR PARSE PDLOV
08700 POPJ P,
08800
08900 BEND TOTAL
09000 IFN FTDEBUG, <↑INNA←INNA>
09100
09200
09300
00100
00200